fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-06 22:55:08 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3:## base/modules/psb_c_base_mat_mod.f03

Browse Source 
base/modules/psb_d_mat_mod.f03
 base/modules/psb_linmap_type_mod.f90
 base/modules/psb_serial_mod.f90
 base/serial/Makefile
 base/serial/f03/psb_c_coo_impl.f03
 base/serial/f03/psb_c_csc_impl.f03
 base/serial/f03/psb_c_csr_impl.f03
 base/serial/f03/psb_d_coo_impl.f03
 base/serial/f03/psb_d_csc_impl.f03
 base/serial/f03/psb_d_csr_impl.f03
 base/serial/f03/psb_d_mat_impl.F03
 base/serial/f03/psb_s_coo_impl.f03
 base/serial/f03/psb_s_csc_impl.f03
 base/serial/f03/psb_s_csr_impl.f03
 base/serial/f03/psb_z_coo_impl.f03
 base/serial/f03/psb_z_csc_impl.f03
 base/serial/f03/psb_z_csr_impl.f03
 opt
 opt/Makefile
 opt/psb_d_ell_impl.f03
 opt/psb_d_ell_mat_mod.f03
 prec/psb_d_base_prec_mod.f03
 prec/psb_d_bjacprec.f03
 prec/psb_d_prec_type.f03
 test/fileread/df_sample.f90
 test/fileread/runs/dfs.inp
 test/serial/d_matgen.f03
 test/serial/psb_d_rsb_mat_mod.F03

1. Fixed get_diag for various cases.
2. OPT subdir for experimental material; right now ELL.
This commit is contained in:
Salvatore Filippone
2010-11-19 16:44:04 +00:00
parent 7eb4a4d1d0
commit 3831be4ef0
28 changed files with 3938 additions and 123 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psb_c_base_mat_mod.f03
+1 -1
View File
@@ -47,7 +47,7 @@
! methods are implemented that allow the direct transition from one
! format to another. The psb_c_coo_sparse_mat type extends the
! psb_c_base_sparse_mat one.
! but is supposed to be overridden at the leaf level.
module psb_c_base_mat_mod
base/modules/psb_d_mat_mod.f03
+15 -1
View File
@@ -109,7 +109,9 @@ module psb_d_mat_mod
procedure, pass(a) :: d_cscnv_base => psb_d_cscnv_base
generic, public :: cscnv => d_cscnv, d_cscnv_ip, d_cscnv_base
procedure, pass(a) :: reinit => psb_d_reinit
procedure, pass(a) :: print => psb_d_sparse_print
procedure, pass(a) :: print_i => psb_d_sparse_print
procedure, pass(a) :: print_n => psb_d_n_sparse_print
generic, public :: print => print_i, print_n
procedure, pass(a) :: d_mv_from => psb_d_mv_from
generic, public :: mv_from => d_mv_from
procedure, pass(a) :: d_mv_to => psb_d_mv_to
@@ -284,6 +286,18 @@ module psb_d_mat_mod
end subroutine psb_d_sparse_print
end interface
interface
subroutine psb_d_n_sparse_print(fname,a,iv,eirs,eics,head,ivr,ivc)
import :: psb_dspmat_type
character(len=*), intent(in) :: fname
class(psb_dspmat_type), intent(in) :: a
integer, intent(in), optional :: iv(:)
integer, intent(in), optional :: eirs,eics
character(len=*), optional :: head
integer, intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_d_n_sparse_print
end interface
interface
subroutine psb_d_get_neigh(a,idx,neigh,n,info,lev)
import :: psb_dspmat_type
base/modules/psb_linmap_type_mod.f90
+2 -1
View File
@@ -37,7 +37,8 @@
!
module psb_linmap_type_mod
use psb_const_mod
use psb_mat_mod, only: psb_dspmat_type, psb_sspmat_type, psb_zspmat_type, psb_cspmat_type
use psb_mat_mod, only: psb_dspmat_type, psb_sspmat_type,&
& psb_zspmat_type, psb_cspmat_type
use psb_descriptor_type, only: psb_desc_type
base/modules/psb_serial_mod.f90
+28
View File
@@ -225,6 +225,34 @@ module psb_serial_mod
logical,intent(in), optional :: rowscale
end subroutine psb_zbase_rwextd
end interface
interface psb_geprt
subroutine psb_dgeprtn2(fname,a,head)
use psb_const_mod, only : psb_spk_, psb_dpk_
character(len=*), intent(in) :: fname
real(psb_dpk_), intent(in) :: a(:,:)
character(len=*), optional :: head
end subroutine psb_dgeprtn2
subroutine psb_dgeprtn1(fname,a,head)
use psb_const_mod, only : psb_spk_, psb_dpk_
character(len=*), intent(in) :: fname
real(psb_dpk_), intent(in) :: a(:)
character(len=*), optional :: head
end subroutine psb_dgeprtn1
subroutine psb_dgeprt2(iout,a,head)
use psb_const_mod, only : psb_spk_, psb_dpk_
integer, intent(in) :: iout
real(psb_dpk_), intent(in) :: a(:,:)
character(len=*), optional :: head
end subroutine psb_dgeprt2
subroutine psb_dgeprt1(iout,a,head)
use psb_const_mod, only : psb_spk_, psb_dpk_
integer, intent(in) :: iout
real(psb_dpk_), intent(in) :: a(:)
character(len=*), optional :: head
end subroutine psb_dgeprt1
end interface
end module psb_serial_mod
base/serial/Makefile
+2 -1
View File
@@ -4,7 +4,8 @@ include ../../Make.inc
FOBJS = psb_lsame.o psi_serial_impl.o psi_impl.o psb_sort_impl.o \
psb_srwextd.o psb_drwextd.o psb_crwextd.o psb_zrwextd.o \
psb_ssymbmm.o psb_dsymbmm.o psb_csymbmm.o psb_zsymbmm.o \
psb_snumbmm.o psb_dnumbmm.o psb_cnumbmm.o psb_znumbmm.o
psb_snumbmm.o psb_dnumbmm.o psb_cnumbmm.o psb_znumbmm.o \
psb_dgeprt.o
LIBDIR=..
MODDIR=../modules
base/serial/f03/psb_c_coo_impl.f03
+11 -8
View File
@@ -21,15 +21,18 @@ subroutine psb_c_coo_get_diag(a,d,info)
call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/))
goto 9999
end if
d(:) = zzero
do i=1,a%get_nzeros()
j=a%ia(i)
if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then
d(j) = a%val(i)
endif
enddo
d(:) = czero
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = cone
else
do i=1,a%get_nzeros()
j=a%ia(i)
if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then
d(j) = a%val(i)
endif
enddo
end if
call psb_erractionrestore(err_act)
return
base/serial/f03/psb_c_csc_impl.f03
+14 -8
View File
@@ -1448,17 +1448,23 @@ subroutine psb_c_csc_get_diag(a,d,info)
end if
do i=1, mnm
do k=a%icp(i),a%icp(i+1)-1
j=a%ia(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = cone
else
do i=1, mnm
d(i) = czero
do k=a%icp(i),a%icp(i+1)-1
j=a%ia(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
end if
do i=mnm+1,size(d)
d(i) = czero
end do
call psb_erractionrestore(err_act)
return
base/serial/f03/psb_c_csr_impl.f03
+15 -9
View File
@@ -1287,17 +1287,23 @@ subroutine psb_c_csr_get_diag(a,d,info)
end if
do i=1, mnm
do k=a%irp(i),a%irp(i+1)-1
j=a%ja(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = cone
else
do i=1, mnm
d(i) = czero
do k=a%irp(i),a%irp(i+1)-1
j=a%ja(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
end if
do i=mnm+1,size(d)
d(i) = dzero
d(i) = czero
end do
call psb_erractionrestore(err_act)
return
base/serial/f03/psb_d_coo_impl.f03
+10 -7
View File
@@ -23,13 +23,16 @@ subroutine psb_d_coo_get_diag(a,d,info)
end if
d(:) = dzero
do i=1,a%get_nzeros()
j=a%ia(i)
if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then
d(j) = a%val(i)
endif
enddo
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = done
else
do i=1,a%get_nzeros()
j=a%ia(i)
if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then
d(j) = a%val(i)
endif
enddo
end if
call psb_erractionrestore(err_act)
return
base/serial/f03/psb_d_csc_impl.f03
+13 -8
View File
@@ -1321,14 +1321,19 @@ subroutine psb_d_csc_get_diag(a,d,info)
end if
do i=1, mnm
do k=a%icp(i),a%icp(i+1)-1
j=a%ia(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = done
else
do i=1, mnm
d(i) = dzero
do k=a%icp(i),a%icp(i+1)-1
j=a%ia(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
endif
do i=mnm+1,size(d)
d(i) = dzero
end do
base/serial/f03/psb_d_csr_impl.f03
+14 -9
View File
@@ -1337,14 +1337,19 @@ subroutine psb_d_csr_get_diag(a,d,info)
end if
do i=1, mnm
do k=a%irp(i),a%irp(i+1)-1
j=a%ja(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = done
else
do i=1, mnm
d(i) = dzero
do k=a%irp(i),a%irp(i+1)-1
j=a%ja(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
end if
do i=mnm+1,size(d)
d(i) = dzero
end do
@@ -1559,7 +1564,7 @@ subroutine psb_d_csr_allocate_mnnz(m,n,a,nz)
if (info == psb_success_) call psb_realloc(nz_,a%ja,info)
if (info == psb_success_) call psb_realloc(nz_,a%val,info)
if (info == psb_success_) then
a%irp=0
a%irp = 0
call a%set_nrows(m)
call a%set_ncols(n)
call a%set_bld()
base/serial/f03/psb_d_mat_impl.F03
+55
View File
@@ -495,6 +495,61 @@ subroutine psb_d_sparse_print(iout,a,iv,eirs,eics,head,ivr,ivc)
end subroutine psb_d_sparse_print
subroutine psb_d_n_sparse_print(fname,a,iv,eirs,eics,head,ivr,ivc)
use psb_d_mat_mod, psb_protect_name => psb_d_n_sparse_print
use psb_error_mod
implicit none
character(len=*), intent(in) :: fname
class(psb_dspmat_type), intent(in) :: a
integer, intent(in), optional :: iv(:)
integer, intent(in), optional :: eirs,eics
character(len=*), optional :: head
integer, intent(in), optional :: ivr(:), ivc(:)
Integer :: err_act, info, iout
logical :: isopen
character(len=20) :: name='sparse_print'
logical, parameter :: debug=.false.
info = psb_success_
call psb_get_erraction(err_act)
if (.not.allocated(a%a)) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
iout = max(psb_inp_unit,psb_err_unit,psb_out_unit) + 1
do
inquire(unit=iout, opened=isopen)
if (.not.isopen) exit
iout = iout + 1
if (iout > 99) exit
end do
if (iout > 99) then
write(psb_err_unit,*) 'Error: could not find a free unit for I/O'
return
end if
open(iout,file=fname,iostat=info)
if (info == psb_success_) then
call a%a%print(iout,iv,eirs,eics,head,ivr,ivc)
close(iout)
else
write(psb_err_unit,*) 'Error: could not open ',fname,' for output'
end if
return
9999 continue
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_d_n_sparse_print
base/serial/f03/psb_s_coo_impl.f03
+10 -7
View File
@@ -23,13 +23,16 @@ subroutine psb_s_coo_get_diag(a,d,info)
end if
d(:) = szero
do i=1,a%get_nzeros()
j=a%ia(i)
if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then
d(j) = a%val(i)
endif
enddo
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = sone
else
do i=1,a%get_nzeros()
j=a%ia(i)
if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then
d(j) = a%val(i)
endif
enddo
end if
call psb_erractionrestore(err_act)
return
base/serial/f03/psb_s_csc_impl.f03
+14 -9
View File
@@ -1086,16 +1086,21 @@ subroutine psb_s_csc_get_diag(a,d,info)
end if
do i=1, mnm
do k=a%icp(i),a%icp(i+1)-1
j=a%ia(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = sone
else
do i=1, mnm
d(i) = szero
do k=a%icp(i),a%icp(i+1)-1
j=a%ia(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
end if
do i=mnm+1,size(d)
d(i) = dzero
d(i) = szero
end do
call psb_erractionrestore(err_act)
return
base/serial/f03/psb_s_csr_impl.f03
+13 -8
View File
@@ -1095,14 +1095,19 @@ subroutine psb_s_csr_get_diag(a,d,info)
end if
do i=1, mnm
do k=a%irp(i),a%irp(i+1)-1
j=a%ja(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = sone
else
do i=1, mnm
d(i) = szero
do k=a%irp(i),a%irp(i+1)-1
j=a%ja(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
end if
do i=mnm+1,size(d)
d(i) = dzero
end do
base/serial/f03/psb_z_coo_impl.f03
+10 -7
View File
@@ -23,13 +23,16 @@ subroutine psb_z_coo_get_diag(a,d,info)
end if
d(:) = zzero
do i=1,a%get_nzeros()
j=a%ia(i)
if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then
d(j) = a%val(i)
endif
enddo
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = zone
else
do i=1,a%get_nzeros()
j=a%ia(i)
if ((j == a%ja(i)) .and.(j <= mnm ) .and.(j>0)) then
d(j) = a%val(i)
endif
enddo
end if
call psb_erractionrestore(err_act)
return
base/serial/f03/psb_z_csc_impl.f03
+13 -8
View File
@@ -1449,14 +1449,19 @@ subroutine psb_z_csc_get_diag(a,d,info)
end if
do i=1, mnm
do k=a%icp(i),a%icp(i+1)-1
j=a%ia(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = zone
else
do i=1, mnm
d(i) = zzero
do k=a%icp(i),a%icp(i+1)-1
j=a%ia(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
end if
do i=mnm+1,size(d)
d(i) = zzero
end do
base/serial/f03/psb_z_csr_impl.f03
+14 -10
View File
@@ -1287,17 +1287,21 @@ subroutine psb_z_csr_get_diag(a,d,info)
goto 9999
end if
do i=1, mnm
do k=a%irp(i),a%irp(i+1)-1
j=a%ja(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = zone
else
do i=1, mnm
d(i) = zzero
do k=a%irp(i),a%irp(i+1)-1
j=a%ja(k)
if ((j == i) .and.(j <= mnm )) then
d(i) = a%val(k)
endif
enddo
end do
end if
do i=mnm+1,size(d)
d(i) = dzero
d(i) = zzero
end do
call psb_erractionrestore(err_act)
return
opt/Makefile
+30
View File
@@ -0,0 +1,30 @@
include ../Make.inc
#
# Libraries used
#
LIBDIR=../lib/
PSBLAS_LIB= -L$(LIBDIR) -lpsb_base
#-lpsb_util -lpsb_krylov -lpsb_prec -lpsb_base
LDLIBS=$(PSBLDLIBS)
#
# Compilers and such
#
CCOPT= -g
FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG).
EXEDIR=./runs
all: psb_d_ell_impl.o psb_d_ell_mat_mod.o
psb_d_ell_impl.o: psb_d_ell_mat_mod.o
clean:
/bin/rm -f psb_d_ell_impl.o psb_d_ell_mat_mod.o *$(.mod)
verycleanlib:
(cd ../..; make veryclean)
lib:
(cd ../../; make library)
opt/psb_d_ell_impl.f03
+3001
View File
File diff suppressed because it is too large Load Diff
opt/psb_d_ell_mat_mod.f03
+505
View File
@@ -0,0 +1,505 @@
module psb_d_ell_mat_mod
use psb_d_base_mat_mod
type, extends(psb_d_base_sparse_mat) :: psb_d_ell_sparse_mat
!
! ITPACK/ELL format, extended.
! Based on M. Heroux "A proposal for a sparse BLAS toolkit".
! IRN is our addition, should help in transferring to/from
! other formats (should come in handy for GPUs).
! Notes:
! 1. JA holds the column indices, padded with the row index.
! 2. VAL holds the coefficients, padded with zeros
! 3. IDIAG hold the position of the diagonal element
! or 0 if it is not there, but is only relevant for
! triangular matrices. In particular, a unit triangular matrix
! will have IDIAG==0.
! 4. IRN holds the actual number of nonzeros stored in each row
! 5. Within a row, the indices are sorted for use of SV.
!
integer, allocatable :: irn(:), ja(:,:), idiag(:)
real(psb_dpk_), allocatable :: val(:,:)
contains
procedure, pass(a) :: get_size => d_ell_get_size
procedure, pass(a) :: get_nzeros => d_ell_get_nzeros
procedure, pass(a) :: get_fmt => d_ell_get_fmt
procedure, pass(a) :: sizeof => d_ell_sizeof
procedure, pass(a) :: d_csmm => psb_d_ell_csmm
procedure, pass(a) :: d_csmv => psb_d_ell_csmv
procedure, pass(a) :: d_inner_cssm => psb_d_ell_cssm
procedure, pass(a) :: d_inner_cssv => psb_d_ell_cssv
procedure, pass(a) :: d_scals => psb_d_ell_scals
procedure, pass(a) :: d_scal => psb_d_ell_scal
procedure, pass(a) :: csnmi => psb_d_ell_csnmi
procedure, pass(a) :: csnm1 => psb_d_ell_csnm1
procedure, pass(a) :: rowsum => psb_d_ell_rowsum
procedure, pass(a) :: arwsum => psb_d_ell_arwsum
procedure, pass(a) :: colsum => psb_d_ell_colsum
procedure, pass(a) :: aclsum => psb_d_ell_aclsum
procedure, pass(a) :: reallocate_nz => psb_d_ell_reallocate_nz
procedure, pass(a) :: allocate_mnnz => psb_d_ell_allocate_mnnz
procedure, pass(a) :: cp_to_coo => psb_d_cp_ell_to_coo
procedure, pass(a) :: cp_from_coo => psb_d_cp_ell_from_coo
procedure, pass(a) :: cp_to_fmt => psb_d_cp_ell_to_fmt
procedure, pass(a) :: cp_from_fmt => psb_d_cp_ell_from_fmt
procedure, pass(a) :: mv_to_coo => psb_d_mv_ell_to_coo
procedure, pass(a) :: mv_from_coo => psb_d_mv_ell_from_coo
procedure, pass(a) :: mv_to_fmt => psb_d_mv_ell_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_d_mv_ell_from_fmt
procedure, pass(a) :: csput => psb_d_ell_csput
procedure, pass(a) :: get_diag => psb_d_ell_get_diag
procedure, pass(a) :: csgetptn => psb_d_ell_csgetptn
procedure, pass(a) :: d_csgetrow => psb_d_ell_csgetrow
procedure, pass(a) :: get_nz_row => d_ell_get_nz_row
procedure, pass(a) :: reinit => psb_d_ell_reinit
procedure, pass(a) :: trim => psb_d_ell_trim
procedure, pass(a) :: print => psb_d_ell_print
procedure, pass(a) :: free => d_ell_free
procedure, pass(a) :: mold => psb_d_ell_mold
procedure, pass(a) :: psb_d_ell_cp_from
generic, public :: cp_from => psb_d_ell_cp_from
procedure, pass(a) :: psb_d_ell_mv_from
generic, public :: mv_from => psb_d_ell_mv_from
end type psb_d_ell_sparse_mat
private :: d_ell_get_nzeros, d_ell_free, d_ell_get_fmt, &
& d_ell_get_size, d_ell_sizeof, d_ell_get_nz_row
interface
subroutine psb_d_ell_reallocate_nz(nz,a)
import :: psb_d_ell_sparse_mat
integer, intent(in) :: nz
class(psb_d_ell_sparse_mat), intent(inout) :: a
end subroutine psb_d_ell_reallocate_nz
end interface
interface
subroutine psb_d_ell_reinit(a,clear)
import :: psb_d_ell_sparse_mat
class(psb_d_ell_sparse_mat), intent(inout) :: a
logical, intent(in), optional :: clear
end subroutine psb_d_ell_reinit
end interface
interface
subroutine psb_d_ell_trim(a)
import :: psb_d_ell_sparse_mat
class(psb_d_ell_sparse_mat), intent(inout) :: a
end subroutine psb_d_ell_trim
end interface
interface
subroutine psb_d_ell_mold(a,b,info)
import :: psb_d_ell_sparse_mat, psb_d_base_sparse_mat, psb_long_int_k_
class(psb_d_ell_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(out), allocatable :: b
integer, intent(out) :: info
end subroutine psb_d_ell_mold
end interface
interface
subroutine psb_d_ell_allocate_mnnz(m,n,a,nz)
import :: psb_d_ell_sparse_mat
integer, intent(in) :: m,n
class(psb_d_ell_sparse_mat), intent(inout) :: a
integer, intent(in), optional :: nz
end subroutine psb_d_ell_allocate_mnnz
end interface
interface
subroutine psb_d_ell_print(iout,a,iv,eirs,eics,head,ivr,ivc)
import :: psb_d_ell_sparse_mat
integer, intent(in) :: iout
class(psb_d_ell_sparse_mat), intent(in) :: a
integer, intent(in), optional :: iv(:)
integer, intent(in), optional :: eirs,eics
character(len=*), optional :: head
integer, intent(in), optional :: ivr(:), ivc(:)
end subroutine psb_d_ell_print
end interface
interface
subroutine psb_d_cp_ell_to_coo(a,b,info)
import :: psb_d_coo_sparse_mat, psb_d_ell_sparse_mat
class(psb_d_ell_sparse_mat), intent(in) :: a
class(psb_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
end subroutine psb_d_cp_ell_to_coo
end interface
interface
subroutine psb_d_cp_ell_from_coo(a,b,info)
import :: psb_d_ell_sparse_mat, psb_d_coo_sparse_mat
class(psb_d_ell_sparse_mat), intent(inout) :: a
class(psb_d_coo_sparse_mat), intent(in) :: b
integer, intent(out) :: info
end subroutine psb_d_cp_ell_from_coo
end interface
interface
subroutine psb_d_cp_ell_to_fmt(a,b,info)
import :: psb_d_ell_sparse_mat, psb_d_base_sparse_mat
class(psb_d_ell_sparse_mat), intent(in) :: a
class(psb_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
end subroutine psb_d_cp_ell_to_fmt
end interface
interface
subroutine psb_d_cp_ell_from_fmt(a,b,info)
import :: psb_d_ell_sparse_mat, psb_d_base_sparse_mat
class(psb_d_ell_sparse_mat), intent(inout) :: a
class(psb_d_base_sparse_mat), intent(in) :: b
integer, intent(out) :: info
end subroutine psb_d_cp_ell_from_fmt
end interface
interface
subroutine psb_d_mv_ell_to_coo(a,b,info)
import :: psb_d_ell_sparse_mat, psb_d_coo_sparse_mat
class(psb_d_ell_sparse_mat), intent(inout) :: a
class(psb_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
end subroutine psb_d_mv_ell_to_coo
end interface
interface
subroutine psb_d_mv_ell_from_coo(a,b,info)
import :: psb_d_ell_sparse_mat, psb_d_coo_sparse_mat
class(psb_d_ell_sparse_mat), intent(inout) :: a
class(psb_d_coo_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
end subroutine psb_d_mv_ell_from_coo
end interface
interface
subroutine psb_d_mv_ell_to_fmt(a,b,info)
import :: psb_d_ell_sparse_mat, psb_d_base_sparse_mat
class(psb_d_ell_sparse_mat), intent(inout) :: a
class(psb_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
end subroutine psb_d_mv_ell_to_fmt
end interface
interface
subroutine psb_d_mv_ell_from_fmt(a,b,info)
import :: psb_d_ell_sparse_mat, psb_d_base_sparse_mat
class(psb_d_ell_sparse_mat), intent(inout) :: a
class(psb_d_base_sparse_mat), intent(inout) :: b
integer, intent(out) :: info
end subroutine psb_d_mv_ell_from_fmt
end interface
interface
subroutine psb_d_ell_cp_from(a,b)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(inout) :: a
type(psb_d_ell_sparse_mat), intent(in) :: b
end subroutine psb_d_ell_cp_from
end interface
interface
subroutine psb_d_ell_mv_from(a,b)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(inout) :: a
type(psb_d_ell_sparse_mat), intent(inout) :: b
end subroutine psb_d_ell_mv_from
end interface
interface
subroutine psb_d_ell_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
integer, intent(in) :: nz,ia(:), ja(:),&
& imin,imax,jmin,jmax
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
end subroutine psb_d_ell_csput
end interface
interface
subroutine psb_d_ell_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
end subroutine psb_d_ell_csgetptn
end interface
interface
subroutine psb_d_ell_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
real(psb_dpk_), allocatable, intent(inout) :: val(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax, nzin
logical, intent(in), optional :: rscale,cscale
end subroutine psb_d_ell_csgetrow
end interface
interface
subroutine psb_d_ell_csgetblk(imin,imax,a,b,info,&
& jmin,jmax,iren,append,rscale,cscale)
import :: psb_d_ell_sparse_mat, psb_dpk_, psb_d_coo_sparse_mat
class(psb_d_ell_sparse_mat), intent(in) :: a
class(psb_d_coo_sparse_mat), intent(inout) :: b
integer, intent(in) :: imin,imax
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
integer, intent(in), optional :: jmin,jmax
logical, intent(in), optional :: rscale,cscale
end subroutine psb_d_ell_csgetblk
end interface
interface
subroutine psb_d_ell_cssv(alpha,a,x,beta,y,info,trans)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
integer, intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_d_ell_cssv
subroutine psb_d_ell_cssm(alpha,a,x,beta,y,info,trans)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
integer, intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_d_ell_cssm
end interface
interface
subroutine psb_d_ell_csmv(alpha,a,x,beta,y,info,trans)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
integer, intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_d_ell_csmv
subroutine psb_d_ell_csmm(alpha,a,x,beta,y,info,trans)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
integer, intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_d_ell_csmm
end interface
interface
function psb_d_ell_csnmi(a) result(res)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_) :: res
end function psb_d_ell_csnmi
end interface
interface
function psb_d_ell_csnm1(a) result(res)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_) :: res
end function psb_d_ell_csnm1
end interface
interface
subroutine psb_d_ell_rowsum(d,a)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
end subroutine psb_d_ell_rowsum
end interface
interface
subroutine psb_d_ell_arwsum(d,a)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
end subroutine psb_d_ell_arwsum
end interface
interface
subroutine psb_d_ell_colsum(d,a)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
end subroutine psb_d_ell_colsum
end interface
interface
subroutine psb_d_ell_aclsum(d,a)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
end subroutine psb_d_ell_aclsum
end interface
interface
subroutine psb_d_ell_get_diag(a,d,info)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_d_ell_get_diag
end interface
interface
subroutine psb_d_ell_scal(d,a,info)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: d(:)
integer, intent(out) :: info
end subroutine psb_d_ell_scal
end interface
interface
subroutine psb_d_ell_scals(d,a,info)
import :: psb_d_ell_sparse_mat, psb_dpk_
class(psb_d_ell_sparse_mat), intent(inout) :: a
real(psb_dpk_), intent(in) :: d
integer, intent(out) :: info
end subroutine psb_d_ell_scals
end interface
contains
! == ===================================
!
!
!
! Getters
!
!
!
!
!
! == ===================================
function d_ell_sizeof(a) result(res)
implicit none
class(psb_d_ell_sparse_mat), intent(in) :: a
integer(psb_long_int_k_) :: res
res = 8
res = res + psb_sizeof_dp * size(a%val)
res = res + psb_sizeof_int * size(a%irn)
res = res + psb_sizeof_int * size(a%idiag)
res = res + psb_sizeof_int * size(a%ja)
end function d_ell_sizeof
function d_ell_get_fmt(a) result(res)
implicit none
class(psb_d_ell_sparse_mat), intent(in) :: a
character(len=5) :: res
res = 'ELL'
end function d_ell_get_fmt
function d_ell_get_nzeros(a) result(res)
implicit none
class(psb_d_ell_sparse_mat), intent(in) :: a
integer :: res
res = sum(a%irn(1:a%get_nrows()))
end function d_ell_get_nzeros
function d_ell_get_size(a) result(res)
implicit none
class(psb_d_ell_sparse_mat), intent(in) :: a
integer :: res
res = -1
if (allocated(a%ja)) then
if (res >= 0) then
res = min(res,size(a%ja))
else
res = size(a%ja)
end if
end if
if (allocated(a%val)) then
if (res >= 0) then
res = min(res,size(a%val))
else
res = size(a%val)
end if
end if
end function d_ell_get_size
function d_ell_get_nz_row(idx,a) result(res)
implicit none
class(psb_d_ell_sparse_mat), intent(in) :: a
integer, intent(in) :: idx
integer :: res
res = 0
if ((1<=idx).and.(idx<=a%get_nrows())) then
res = a%irn(idx)
end if
end function d_ell_get_nz_row
! == ===================================
!
!
!
! Data management
!
!
!
!
!
! == ===================================
subroutine d_ell_free(a)
implicit none
class(psb_d_ell_sparse_mat), intent(inout) :: a
if (allocated(a%idiag)) deallocate(a%idiag)
if (allocated(a%irn)) deallocate(a%irn)
if (allocated(a%ja)) deallocate(a%ja)
if (allocated(a%val)) deallocate(a%val)
call a%set_null()
call a%set_nrows(0)
call a%set_ncols(0)
return
end subroutine d_ell_free
end module psb_d_ell_mat_mod
prec/psb_d_base_prec_mod.f03
+56 -1
View File
@@ -45,7 +45,10 @@ module psb_d_base_prec_mod
use psb_prec_const_mod
type psb_d_base_prec_type
integer :: ictxt
contains
procedure, pass(prec) :: set_ctxt => psb_d_base_set_ctxt
procedure, pass(prec) :: get_ctxt => psb_d_base_get_ctxt
procedure, pass(prec) :: apply => psb_d_base_apply
procedure, pass(prec) :: precbld => psb_d_base_precbld
procedure, pass(prec) :: precseti => psb_d_base_precseti
@@ -56,11 +59,13 @@ module psb_d_base_prec_mod
procedure, pass(prec) :: precinit => psb_d_base_precinit
procedure, pass(prec) :: precfree => psb_d_base_precfree
procedure, pass(prec) :: precdescr => psb_d_base_precdescr
procedure, pass(prec) :: dump => psb_d_base_precdump
end type psb_d_base_prec_type
private :: psb_d_base_apply, psb_d_base_precbld, psb_d_base_precseti,&
& psb_d_base_precsetr, psb_d_base_precsetc, psb_d_base_sizeof,&
& psb_d_base_precinit, psb_d_base_precfree, psb_d_base_precdescr
& psb_d_base_precinit, psb_d_base_precfree, psb_d_base_precdescr,&
& psb_d_base_precdump, psb_d_base_set_ctxt
contains
@@ -339,6 +344,47 @@ contains
end subroutine psb_d_base_precdescr
subroutine psb_d_base_precdump(prec,info,prefix,head)
use psb_sparse_mod
implicit none
class(psb_d_base_prec_type), intent(in) :: prec
integer, intent(out) :: info
character(len=*), intent(in), optional :: prefix,head
Integer :: err_act, nrow
character(len=20) :: name='d_base_precdump'
call psb_erractionsave(err_act)
!
! This is the base version and we should throw an error.
! Or should it be the NULL preonditioner???
!
info = 700
call psb_errpush(info,name)
goto 9999
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error()
return
end if
return
end subroutine psb_d_base_precdump
subroutine psb_d_base_set_ctxt(prec,ictxt)
use psb_sparse_mod
implicit none
class(psb_d_base_prec_type), intent(inout) :: prec
integer, intent(in) :: ictxt
prec%ictxt = ictxt
end subroutine psb_d_base_set_ctxt
function psb_d_base_sizeof(prec) result(val)
use psb_sparse_mod
@@ -349,4 +395,13 @@ contains
return
end function psb_d_base_sizeof
function psb_d_base_get_ctxt(prec) result(val)
use psb_sparse_mod
class(psb_d_base_prec_type), intent(in) :: prec
integer :: val
val = prec%ictxt
return
end function psb_d_base_get_ctxt
end module psb_d_base_prec_mod
prec/psb_d_bjacprec.f03
+50 -6
View File
@@ -1,11 +1,10 @@
module psb_d_bjacprec
use psb_d_base_prec_mod
type, extends(psb_d_base_prec_type) :: psb_d_bjac_prec_type
integer, allocatable :: iprcparm(:)
type, extends(psb_d_base_prec_type) :: psb_d_bjac_prec_type
integer, allocatable :: iprcparm(:)
type(psb_dspmat_type), allocatable :: av(:)
real(psb_dpk_), allocatable :: d(:)
real(psb_dpk_), allocatable :: d(:)
contains
procedure, pass(prec) :: apply => psb_d_bjac_apply
procedure, pass(prec) :: precbld => psb_d_bjac_precbld
@@ -15,12 +14,14 @@ module psb_d_bjacprec
procedure, pass(prec) :: precsetc => psb_d_bjac_precsetc
procedure, pass(prec) :: precfree => psb_d_bjac_precfree
procedure, pass(prec) :: precdescr => psb_d_bjac_precdescr
procedure, pass(prec) :: dump => psb_d_bjac_dump
procedure, pass(prec) :: sizeof => psb_d_bjac_sizeof
end type psb_d_bjac_prec_type
private :: psb_d_bjac_apply, psb_d_bjac_precbld, psb_d_bjac_precseti,&
& psb_d_bjac_precsetr, psb_d_bjac_precsetc, psb_d_bjac_sizeof,&
& psb_d_bjac_precinit, psb_d_bjac_precfree, psb_d_bjac_precdescr
& psb_d_bjac_precinit, psb_d_bjac_precfree, psb_d_bjac_precdescr,&
& psb_d_bjac_dump
character(len=15), parameter, private :: &
@@ -240,6 +241,8 @@ contains
ictxt=psb_cd_get_context(desc_a)
call psb_info(ictxt, me, np)
call prec%set_ctxt(ictxt)
m = a%get_nrows()
if (m < 0) then
info = psb_err_iarg_neg_
@@ -288,7 +291,8 @@ contains
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
write(0,*) allocated(lf%irp),allocated(lf%ja),allocated(lf%val)
write(0,*) allocated(uf%irp),allocated(uf%ja),allocated(uf%val)
if (allocated(prec%d)) then
if (size(prec%d) < n_row) then
deallocate(prec%d)
@@ -548,6 +552,46 @@ contains
end subroutine psb_d_bjac_precdescr
subroutine psb_d_bjac_dump(prec,info,prefix,head)
use psb_sparse_mod
implicit none
class(psb_d_bjac_prec_type), intent(in) :: prec
integer, intent(out) :: info
character(len=*), intent(in), optional :: prefix,head
integer :: i, j, il1, iln, lname, lev
integer :: ictxt,iam, np
character(len=80) :: prefix_
character(len=120) :: fname ! len should be at least 20 more than
! len of prefix_
info = 0
ictxt = prec%get_ctxt()
call psb_info(ictxt,iam,np)
if (present(prefix)) then
prefix_ = trim(prefix(1:min(len(prefix),len(prefix_))))
else
prefix_ = "dump_fact_d"
end if
lname = len_trim(prefix_)
fname = trim(prefix_)
write(fname(lname+1:lname+5),'(a,i3.3)') '_p',iam
lname = lname + 5
write(fname(lname+1:),'(a)')'_lower.mtx'
if (prec%av(psb_l_pr_)%is_asb()) &
& call prec%av(psb_l_pr_)%print(fname,head=head)
write(fname(lname+1:),'(a,a)')'_diag.mtx'
if (allocated(prec%d)) &
& call psb_geprt(fname,prec%d,head=head)
write(fname(lname+1:),'(a)')'_upper.mtx'
if (prec%av(psb_u_pr_)%is_asb()) &
& call prec%av(psb_u_pr_)%print(fname,head=head)
end subroutine psb_d_bjac_dump
function psb_d_bjac_sizeof(prec) result(val)
use psb_sparse_mod
class(psb_d_bjac_prec_type), intent(in) :: prec
prec/psb_d_prec_type.f03
+27
View File
@@ -66,6 +66,10 @@ module psb_d_prec_type
module procedure psb_file_prec_descr
end interface
interface psb_precdump
module procedure psb_d_prec_dump
end interface
interface psb_sizeof
module procedure psb_dprec_sizeof
end interface
@@ -118,6 +122,29 @@ contains
end subroutine psb_file_prec_descr
subroutine psb_d_prec_dump(prec,info,prefix,head)
use psb_sparse_mod
implicit none
type(psb_dprec_type), intent(in) :: prec
integer, intent(out) :: info
character(len=*), intent(in), optional :: prefix,head
! len of prefix_
info = 0
if (.not.allocated(prec%prec)) then
info = -1
write(psb_err_unit,*) 'Trying to dump a non-built preconditioner'
return
end if
call prec%prec%dump(info,prefix,head)
end subroutine psb_d_prec_dump
subroutine psb_d_precfree(p,info)
use psb_sparse_mod
type(psb_dprec_type), intent(inout) :: p
test/fileread/df_sample.f90
+1
View File
@@ -272,6 +272,7 @@ program df_sample
write(psb_out_unit,'("Total memory occupation for DESC_A: ",i12)')descsize
write(psb_out_unit,'("Total memory occupation for PREC: ",i12)')precsize
end if
call psb_precdump(prec,info,prefix=mtrx_file//'_')
allocate(x_col_glob(m_problem),r_col_glob(m_problem),stat=ierr)
if (ierr /= 0) then
test/fileread/runs/dfs.inp
+1 -1
View File
@@ -1,5 +1,5 @@
11 Number of inputs
sherman3.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or
thm50x30.mtx This (and others) from: http://math.nist.gov/MatrixMarket/ or
NONE sherman3_rhs1.mtx http://www.cise.ufl.edu/research/sparse/matrices/index.html
MM File format: MM: Matrix Market HB: Harwell-Boeing.
BICGSTAB Iterative method: BiCGSTAB CGS RGMRES BiCGSTABL BICG CG
test/serial/d_matgen.f03
+11 -11
View File
@@ -427,17 +427,17 @@ contains
!write (*,*) acxx%val
!write (*,*) diag
t1 = psb_wtime()
call a_n%cscnv(info,mold=acsr)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
ch_err='asb rout.'
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
tmov = psb_wtime()-t1
!!$ call a_n%print(21)
!!$ t1 = psb_wtime()
!!$ call a_n%cscnv(info,mold=acsr)
!!$
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ ch_err='asb rout.'
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ end if
!!$ tmov = psb_wtime()-t1
! !$ call a_n%print(21)
anorm = a_n%csnmi()
write(psb_err_unit,*) 'Nrm infinity ',anorm
test/serial/psb_d_rsb_mat_mod.F03
+2 -2
View File
@@ -11,7 +11,7 @@ module psb_d_rsb_mat_mod
use psb_d_base_mat_mod
use rsb_mod
#ifdef HAVE_LIBRSB
use iso_c_binding
use iso_c_binding
#endif
#if 1
#define PSBRSB_DEBUG(MSG) write(*,*) __FILE__,':',__LINE__,':',MSG
@@ -26,7 +26,7 @@ module psb_d_rsb_mat_mod
type, extends(psb_d_base_sparse_mat) :: psb_d_rsb_sparse_mat
#ifdef HAVE_LIBRSB
type(c_ptr) :: rsbmptr
contains
contains
procedure, pass(a) :: get_size => d_rsb_get_size
procedure, pass(a) :: get_nzeros => d_rsb_get_nzeros
procedure, pass(a) :: get_ncols => d_rsb_get_ncols