mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-20 12:52:14 +00:00
psblas3:
base/modules/psb_d_mat_mod.f03 base/modules/psb_s_mat_mod.f03 test/fileread/runs/dfs.inp test/serial/d_coo_matgen.f03 test/serial/d_matgen.f03 test/serial/psb_d_cxx_impl.f03 test/serial/psb_d_cxx_mat_mod.f03 Fixes: introduced clip_diag for use with point Jacobi preconditioners.
This commit is contained in:
Salvatore Filippone
@@ -56,6 +56,9 @@ module psb_d_mat_mod
|
||||
procedure, pass(a) :: d_csclip
|
||||
procedure, pass(a) :: d_b_csclip
|
||||
generic, public :: csclip => d_b_csclip, d_csclip
|
||||
procedure, pass(a) :: d_clip_d_ip
|
||||
procedure, pass(a) :: d_clip_d
|
||||
generic, public :: clip_diag => d_clip_d_ip, d_clip_d
|
||||
procedure, pass(a) :: reall => reallocate_nz
|
||||
procedure, pass(a) :: get_neigh
|
||||
procedure, pass(a) :: d_cscnv
|
||||
@@ -99,7 +102,7 @@ module psb_d_mat_mod
|
||||
private :: get_nrows, get_ncols, get_nzeros, get_size, &
|
||||
& get_state, get_dupl, is_null, is_bld, is_upd, &
|
||||
& is_asb, is_sorted, is_upper, is_lower, is_triangle, &
|
||||
& is_unit, get_neigh, csall, csput, d_csgetrow,&
|
||||
& is_unit, get_neigh, csall, csput, d_csgetrow, d_clip_d_ip, d_clip_d,&
|
||||
& d_csgetblk, d_csclip, d_b_csclip, d_cscnv, d_cscnv_ip, &
|
||||
& reallocate_nz, free, trim, &
|
||||
& sparse_print, reinit, &
|
||||
@@ -1599,6 +1602,125 @@ contains
|
||||
end subroutine d_cscnv_base
|
||||
|
||||
|
||||
subroutine d_clip_d(a,b,info)
|
||||
! Output is always in COO format
|
||||
use psb_error_mod
|
||||
use psb_const_mod
|
||||
use psb_d_base_mat_mod
|
||||
implicit none
|
||||
|
||||
class(psb_d_sparse_mat), intent(in) :: a
|
||||
class(psb_d_sparse_mat), intent(out) :: b
|
||||
integer,intent(out) :: info
|
||||
|
||||
Integer :: err_act
|
||||
character(len=20) :: name='clip_diag'
|
||||
logical, parameter :: debug=.false.
|
||||
type(psb_d_coo_sparse_mat), allocatable :: acoo
|
||||
integer :: i, j, nz
|
||||
|
||||
info = 0
|
||||
call psb_erractionsave(err_act)
|
||||
if (a%is_null()) then
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
allocate(acoo,stat=info)
|
||||
if (info == 0) call a%a%cp_to_coo(acoo,info)
|
||||
if (info /= 0) then
|
||||
info = 4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
nz = acoo%get_nzeros()
|
||||
j = 0
|
||||
do i=1, nz
|
||||
if (acoo%ia(i) /= acoo%ja(i)) then
|
||||
j = j + 1
|
||||
acoo%ia(j) = acoo%ia(i)
|
||||
acoo%ja(j) = acoo%ja(i)
|
||||
acoo%val(j) = acoo%val(i)
|
||||
end if
|
||||
end do
|
||||
call acoo%set_nzeros(j)
|
||||
call acoo%trim()
|
||||
call b%mv_from(acoo)
|
||||
|
||||
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
|
||||
|
||||
end subroutine d_clip_d
|
||||
|
||||
|
||||
subroutine d_clip_d_ip(a,info)
|
||||
! Output is always in COO format
|
||||
use psb_error_mod
|
||||
use psb_const_mod
|
||||
use psb_d_base_mat_mod
|
||||
implicit none
|
||||
|
||||
class(psb_d_sparse_mat), intent(inout) :: a
|
||||
integer,intent(out) :: info
|
||||
|
||||
Integer :: err_act
|
||||
character(len=20) :: name='clip_diag'
|
||||
logical, parameter :: debug=.false.
|
||||
type(psb_d_coo_sparse_mat), allocatable :: acoo
|
||||
integer :: i, j, nz
|
||||
|
||||
info = 0
|
||||
call psb_erractionsave(err_act)
|
||||
if (a%is_null()) then
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
allocate(acoo,stat=info)
|
||||
if (info == 0) call a%a%mv_to_coo(acoo,info)
|
||||
if (info /= 0) then
|
||||
info = 4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
nz = acoo%get_nzeros()
|
||||
j = 0
|
||||
do i=1, nz
|
||||
if (acoo%ia(i) /= acoo%ja(i)) then
|
||||
j = j + 1
|
||||
acoo%ia(j) = acoo%ia(i)
|
||||
acoo%ja(j) = acoo%ja(i)
|
||||
acoo%val(j) = acoo%val(i)
|
||||
end if
|
||||
end do
|
||||
call acoo%set_nzeros(j)
|
||||
call acoo%trim()
|
||||
call a%mv_from(acoo)
|
||||
|
||||
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
|
||||
|
||||
end subroutine d_clip_d_ip
|
||||
|
||||
subroutine d_mv_from(a,b)
|
||||
use psb_error_mod
|
||||
|
||||
@@ -54,6 +54,9 @@ module psb_s_mat_mod
|
||||
procedure, pass(a) :: s_csgetblk
|
||||
generic, public :: csget => s_csgetptn, s_csgetrow, s_csgetblk
|
||||
procedure, pass(a) :: csclip
|
||||
procedure, pass(a) :: s_clip_d_ip
|
||||
procedure, pass(a) :: s_clip_d
|
||||
generic, public :: clip_diag => s_clip_d_ip, s_clip_d
|
||||
procedure, pass(a) :: reall => reallocate_nz
|
||||
procedure, pass(a) :: get_neigh
|
||||
procedure, pass(a) :: s_cscnv
|
||||
@@ -63,8 +66,19 @@ module psb_s_mat_mod
|
||||
procedure, pass(a) :: print => sparse_print
|
||||
procedure, pass(a) :: s_mv_from
|
||||
generic, public :: mv_from => s_mv_from
|
||||
procedure, pass(a) :: s_mv_to
|
||||
generic, public :: mv_to => s_mv_to
|
||||
procedure, pass(a) :: s_cp_from
|
||||
generic, public :: cp_from => s_cp_from
|
||||
procedure, pass(a) :: s_cp_to
|
||||
generic, public :: cp_to => s_cp_to
|
||||
procedure, pass(a) :: s_transp_1mat
|
||||
procedure, pass(a) :: s_transp_2mat
|
||||
generic, public :: transp => s_transp_1mat, s_transp_2mat
|
||||
procedure, pass(a) :: s_transc_1mat
|
||||
procedure, pass(a) :: s_transc_2mat
|
||||
generic, public :: transc => s_transc_1mat, s_transc_2mat
|
||||
|
||||
|
||||
|
||||
! Computational routines
|
||||
@@ -85,7 +99,7 @@ module psb_s_mat_mod
|
||||
private :: get_nrows, get_ncols, get_nzeros, get_size, &
|
||||
& get_state, get_dupl, is_null, is_bld, is_upd, &
|
||||
& is_asb, is_sorted, is_upper, is_lower, is_triangle, &
|
||||
& is_unit, get_neigh, csall, csput, s_csgetrow,&
|
||||
& is_unit, get_neigh, csall, csput, s_csgetrow, s_clip_d_ip, s_clip_d,&
|
||||
& s_csgetblk, csclip, s_cscnv, s_cscnv_ip, &
|
||||
& reallocate_nz, free, trim, &
|
||||
& sparse_print, reinit, &
|
||||
@@ -94,7 +108,9 @@ module psb_s_mat_mod
|
||||
& set_upd, set_asb, set_sorted, &
|
||||
& set_upper, set_lower, set_triangle, &
|
||||
& set_unit, get_diag, get_nz_row, s_csgetptn, &
|
||||
& s_mv_from, s_cp_from
|
||||
& s_mv_from, s_mv_to, s_cp_from, s_cp_to,&
|
||||
& s_transp_1mat, s_transp_2mat, &
|
||||
& s_transc_1mat, s_transc_2mat
|
||||
|
||||
interface psb_sizeof
|
||||
module procedure s_sizeof
|
||||
@@ -1486,6 +1502,126 @@ contains
|
||||
|
||||
end subroutine s_cscnv_ip
|
||||
|
||||
subroutine s_clip_d(a,b,info)
|
||||
! Output is always in COO format
|
||||
use psb_error_mod
|
||||
use psb_const_mod
|
||||
use psb_s_base_mat_mod
|
||||
implicit none
|
||||
|
||||
class(psb_s_sparse_mat), intent(in) :: a
|
||||
class(psb_s_sparse_mat), intent(out) :: b
|
||||
integer,intent(out) :: info
|
||||
|
||||
Integer :: err_act
|
||||
character(len=20) :: name='clip_diag'
|
||||
logical, parameter :: debug=.false.
|
||||
type(psb_s_coo_sparse_mat), allocatable :: acoo
|
||||
integer :: i, j, nz
|
||||
|
||||
info = 0
|
||||
call psb_erractionsave(err_act)
|
||||
if (a%is_null()) then
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
allocate(acoo,stat=info)
|
||||
if (info == 0) call a%a%cp_to_coo(acoo,info)
|
||||
if (info /= 0) then
|
||||
info = 4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
nz = acoo%get_nzeros()
|
||||
j = 0
|
||||
do i=1, nz
|
||||
if (acoo%ia(i) /= acoo%ja(i)) then
|
||||
j = j + 1
|
||||
acoo%ia(j) = acoo%ia(i)
|
||||
acoo%ja(j) = acoo%ja(i)
|
||||
acoo%val(j) = acoo%val(i)
|
||||
end if
|
||||
end do
|
||||
call acoo%set_nzeros(j)
|
||||
call acoo%trim()
|
||||
call b%mv_from(acoo)
|
||||
|
||||
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
|
||||
|
||||
end subroutine s_clip_d
|
||||
|
||||
|
||||
subroutine s_clip_d_ip(a,info)
|
||||
! Output is always in COO format
|
||||
use psb_error_mod
|
||||
use psb_const_mod
|
||||
use psb_s_base_mat_mod
|
||||
implicit none
|
||||
|
||||
class(psb_s_sparse_mat), intent(inout) :: a
|
||||
integer,intent(out) :: info
|
||||
|
||||
Integer :: err_act
|
||||
character(len=20) :: name='clip_diag'
|
||||
logical, parameter :: debug=.false.
|
||||
type(psb_s_coo_sparse_mat), allocatable :: acoo
|
||||
integer :: i, j, nz
|
||||
|
||||
info = 0
|
||||
call psb_erractionsave(err_act)
|
||||
if (a%is_null()) then
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
allocate(acoo,stat=info)
|
||||
if (info == 0) call a%a%mv_to_coo(acoo,info)
|
||||
if (info /= 0) then
|
||||
info = 4000
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
nz = acoo%get_nzeros()
|
||||
j = 0
|
||||
do i=1, nz
|
||||
if (acoo%ia(i) /= acoo%ja(i)) then
|
||||
j = j + 1
|
||||
acoo%ia(j) = acoo%ia(i)
|
||||
acoo%ja(j) = acoo%ja(i)
|
||||
acoo%val(j) = acoo%val(i)
|
||||
end if
|
||||
end do
|
||||
call acoo%set_nzeros(j)
|
||||
call acoo%trim()
|
||||
call a%mv_from(acoo)
|
||||
|
||||
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
|
||||
|
||||
end subroutine s_clip_d_ip
|
||||
|
||||
subroutine s_mv_from(a,b)
|
||||
use psb_error_mod
|
||||
use psb_string_mod
|
||||
@@ -1530,6 +1666,32 @@ contains
|
||||
end if
|
||||
end subroutine s_cp_from
|
||||
|
||||
subroutine s_mv_to(a,b)
|
||||
use psb_error_mod
|
||||
use psb_string_mod
|
||||
implicit none
|
||||
class(psb_s_sparse_mat), intent(inout) :: a
|
||||
class(psb_s_base_sparse_mat), intent(out) :: b
|
||||
integer :: info
|
||||
|
||||
call b%mv_from_fmt(a%a,info)
|
||||
|
||||
return
|
||||
end subroutine s_mv_to
|
||||
|
||||
subroutine s_cp_to(a,b)
|
||||
use psb_error_mod
|
||||
use psb_string_mod
|
||||
implicit none
|
||||
class(psb_s_sparse_mat), intent(in) :: a
|
||||
class(psb_s_base_sparse_mat), intent(out) :: b
|
||||
integer :: info
|
||||
|
||||
call b%cp_from_fmt(a%a,info)
|
||||
|
||||
return
|
||||
end subroutine s_cp_to
|
||||
|
||||
subroutine s_sparse_mat_move(a,b,info)
|
||||
use psb_error_mod
|
||||
use psb_string_mod
|
||||
@@ -1582,6 +1744,153 @@ contains
|
||||
end subroutine s_sparse_mat_clone
|
||||
|
||||
|
||||
subroutine s_transp_1mat(a)
|
||||
use psb_error_mod
|
||||
use psb_string_mod
|
||||
implicit none
|
||||
class(psb_s_sparse_mat), intent(inout) :: a
|
||||
|
||||
Integer :: err_act, info
|
||||
character(len=20) :: name='transp'
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
if (a%is_null()) then
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
call a%a%transp()
|
||||
|
||||
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
|
||||
|
||||
end subroutine s_transp_1mat
|
||||
|
||||
|
||||
subroutine s_transp_2mat(a,b)
|
||||
use psb_error_mod
|
||||
use psb_string_mod
|
||||
implicit none
|
||||
class(psb_s_sparse_mat), intent(out) :: a
|
||||
class(psb_s_sparse_mat), intent(in) :: b
|
||||
|
||||
Integer :: err_act, info
|
||||
character(len=20) :: name='transp'
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
if (b%is_null()) then
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
allocate(a%a,source=b%a,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 4000
|
||||
goto 9999
|
||||
end if
|
||||
call a%a%transp(b%a)
|
||||
|
||||
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
|
||||
|
||||
end subroutine s_transp_2mat
|
||||
|
||||
subroutine s_transc_1mat(a)
|
||||
use psb_error_mod
|
||||
use psb_string_mod
|
||||
implicit none
|
||||
class(psb_s_sparse_mat), intent(inout) :: a
|
||||
|
||||
Integer :: err_act, info
|
||||
character(len=20) :: name='transc'
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
if (a%is_null()) then
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
call a%a%transc()
|
||||
|
||||
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
|
||||
|
||||
end subroutine s_transc_1mat
|
||||
|
||||
|
||||
subroutine s_transc_2mat(a,b)
|
||||
use psb_error_mod
|
||||
use psb_string_mod
|
||||
implicit none
|
||||
class(psb_s_sparse_mat), intent(out) :: a
|
||||
class(psb_s_sparse_mat), intent(in) :: b
|
||||
|
||||
Integer :: err_act, info
|
||||
character(len=20) :: name='transc'
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
if (b%is_null()) then
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
endif
|
||||
|
||||
allocate(a%a,source=b%a,stat=info)
|
||||
if (info /= 0) then
|
||||
info = 4000
|
||||
goto 9999
|
||||
end if
|
||||
call a%a%transc(b%a)
|
||||
|
||||
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
|
||||
|
||||
end subroutine s_transc_2mat
|
||||
|
||||
|
||||
subroutine reinit(a,clear)
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
@@ -7,7 +7,7 @@ BJAC Preconditioner NONE DIAG BJAC
|
||||
CSR Storage format CSR COO JAD
|
||||
0 IPART: Partition method 0: BLK 2: graph (with Metis)
|
||||
2 ISTOPC
|
||||
00010 ITMAX
|
||||
00200 ITMAX
|
||||
01 ITRACE
|
||||
30 IRST (restart for RGMRES and BiCGSTABL)
|
||||
1.d-6 EPS
|
||||
|
||||
@@ -17,7 +17,7 @@ program d_coo_matgen
|
||||
real(psb_dpk_) :: t1, t2, tprec
|
||||
|
||||
! sparse matrix and preconditioner
|
||||
type(psb_dspmat_type) :: a
|
||||
type(psb_d_sparse_mat) :: a
|
||||
type(psb_dprec_type) :: prec
|
||||
! descriptor
|
||||
type(psb_desc_type) :: desc_a
|
||||
@@ -145,7 +145,7 @@ contains
|
||||
type(psb_desc_type) :: desc_a
|
||||
integer :: ictxt, info
|
||||
character :: afmt*5
|
||||
type(psb_dspmat_type) :: a
|
||||
type(psb_d_sparse_mat) :: a
|
||||
real(psb_dpk_) :: zt(nb),glob_x,glob_y,glob_z
|
||||
integer :: m,n,nnz,glob_row,nlr,i,ii,ib,k
|
||||
integer :: x,y,z,ia,indx_owner
|
||||
@@ -161,10 +161,10 @@ contains
|
||||
real(psb_dpk_),parameter :: rhs=0.d0,one=1.d0,zero=0.d0
|
||||
real(psb_dpk_) :: t0, t1, t2, t3, tasb, talc, ttot, tgen, tcpy, tmov
|
||||
real(psb_dpk_) :: a1, a2, a3, a4, b1, b2, b3
|
||||
external :: a1, a2, a3, a4, b1, b2, b3
|
||||
integer :: err_act
|
||||
external :: a1, a2, a3, a4, b1, b2, b3
|
||||
integer :: err_act
|
||||
|
||||
character(len=20) :: name, ch_err
|
||||
character(len=20) :: name, ch_err, asbfmt
|
||||
|
||||
info = 0
|
||||
name = 'create_matrix'
|
||||
@@ -404,8 +404,9 @@ contains
|
||||
tmov = psb_wtime()-t1
|
||||
!!$ call acsr%print(22)
|
||||
if(iam == psb_root_) then
|
||||
asbfmt = a%get_fmt()
|
||||
write(*,'("The matrix has been generated and assembled in ",a3," format.")')&
|
||||
& a%fida(1:3)
|
||||
& asbfmt
|
||||
write(*,'("-allocation time : ",es12.5)') talc
|
||||
write(*,'("-coeff. gen. time : ",es12.5)') tgen
|
||||
write(*,'("-assembly time : ",es12.5)') tasb
|
||||
|
||||
@@ -18,7 +18,7 @@ program d_matgen
|
||||
real(psb_dpk_) :: t1, t2, tprec
|
||||
|
||||
! sparse matrix and preconditioner
|
||||
type(psb_dspmat_type) :: a
|
||||
type(psb_d_sparse_mat) :: a
|
||||
type(psb_dprec_type) :: prec
|
||||
! descriptor
|
||||
type(psb_desc_type) :: desc_a
|
||||
@@ -147,7 +147,7 @@ contains
|
||||
type(psb_desc_type) :: desc_a
|
||||
integer :: ictxt, info
|
||||
character :: afmt*5
|
||||
type(psb_dspmat_type) :: a
|
||||
type(psb_d_sparse_mat) :: a
|
||||
real(psb_dpk_) :: zt(nb),glob_x,glob_y,glob_z
|
||||
integer :: m,n,nnz,glob_row,nlr,i,ii,ib,k
|
||||
integer :: x,y,z,ia,indx_owner
|
||||
@@ -165,8 +165,8 @@ contains
|
||||
real(psb_dpk_),parameter :: rhs=0.d0,one=1.d0,zero=0.d0
|
||||
real(psb_dpk_) :: t0, t1, t2, t3, tasb, talc, ttot, tgen, tcpy, tmov
|
||||
real(psb_dpk_) :: a1, a2, a3, a4, b1, b2, b3
|
||||
external :: a1, a2, a3, a4, b1, b2, b3
|
||||
integer :: err_act
|
||||
external :: a1, a2, a3, a4, b1, b2, b3
|
||||
integer :: err_act
|
||||
|
||||
character(len=20) :: name, ch_err
|
||||
|
||||
|
||||
+836
-576
File diff suppressed because it is too large
Load Diff
@@ -29,12 +29,22 @@ module psb_d_cxx_mat_mod
|
||||
procedure, pass(a) :: mv_from_coo => d_mv_cxx_from_coo
|
||||
procedure, pass(a) :: mv_to_fmt => d_mv_cxx_to_fmt
|
||||
procedure, pass(a) :: mv_from_fmt => d_mv_cxx_from_fmt
|
||||
procedure, pass(a) :: csgetptn => d_cxx_csgetptn
|
||||
procedure, pass(a) :: d_csgetrow => d_cxx_csgetrow
|
||||
procedure, pass(a) :: get_nz_row => d_cxx_get_nz_row
|
||||
procedure, pass(a) :: get_size => d_cxx_get_size
|
||||
procedure, pass(a) :: free => d_cxx_free
|
||||
procedure, pass(a) :: trim => d_cxx_trim
|
||||
procedure, pass(a) :: print => d_cxx_print
|
||||
procedure, pass(a) :: sizeof => d_cxx_sizeof
|
||||
procedure, pass(a) :: reinit => d_cxx_reinit
|
||||
procedure, pass(a) :: d_cxx_cp_from
|
||||
generic, public :: cp_from => d_cxx_cp_from
|
||||
procedure, pass(a) :: d_cxx_mv_from
|
||||
generic, public :: mv_from => d_cxx_mv_from
|
||||
|
||||
end type psb_d_cxx_sparse_mat
|
||||
|
||||
private :: d_cxx_get_nzeros, d_cxx_csmm, d_cxx_csmv, d_cxx_cssm, d_cxx_cssv, &
|
||||
& d_cxx_csput, d_cxx_reallocate_nz, d_cxx_allocate_mnnz, &
|
||||
& d_cxx_free, d_cxx_print, d_cxx_get_fmt, d_cxx_csnmi, get_diag, &
|
||||
@@ -42,7 +52,8 @@ module psb_d_cxx_mat_mod
|
||||
& d_mv_cxx_to_coo, d_mv_cxx_from_coo, &
|
||||
& d_cp_cxx_to_fmt, d_cp_cxx_from_fmt, &
|
||||
& d_mv_cxx_to_fmt, d_mv_cxx_from_fmt, &
|
||||
& d_cxx_scals, d_cxx_scal, d_cxx_trim, d_cxx_csgetrow, d_cxx_get_size
|
||||
& d_cxx_scals, d_cxx_scal, d_cxx_trim, d_cxx_csgetrow, d_cxx_get_size, &
|
||||
& d_cxx_sizeof, d_cxx_csgetptn, d_cxx_get_nz_row, d_cxx_reinit
|
||||
|
||||
|
||||
interface
|
||||
@@ -147,6 +158,25 @@ module psb_d_cxx_mat_mod
|
||||
end subroutine d_cxx_csput_impl
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine d_cxx_csgetptn_impl(imin,imax,a,nz,ia,ja,info,&
|
||||
& jmin,jmax,iren,append,nzin,rscale,cscale)
|
||||
use psb_const_mod
|
||||
import psb_d_cxx_sparse_mat
|
||||
implicit none
|
||||
|
||||
class(psb_d_cxx_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 d_cxx_csgetptn_impl
|
||||
end interface
|
||||
|
||||
interface
|
||||
subroutine d_cxx_csgetrow_impl(imin,imax,a,nz,ia,ja,val,info,&
|
||||
& jmin,jmax,iren,append,nzin,rscale,cscale)
|
||||
@@ -234,6 +264,18 @@ contains
|
||||
!
|
||||
!=====================================
|
||||
|
||||
|
||||
function d_cxx_sizeof(a) result(res)
|
||||
implicit none
|
||||
class(psb_d_cxx_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%irp)
|
||||
res = res + psb_sizeof_int * size(a%ja)
|
||||
|
||||
end function d_cxx_sizeof
|
||||
|
||||
function d_cxx_get_fmt(a) result(res)
|
||||
implicit none
|
||||
class(psb_d_cxx_sparse_mat), intent(in) :: a
|
||||
@@ -245,7 +287,7 @@ contains
|
||||
implicit none
|
||||
class(psb_d_cxx_sparse_mat), intent(in) :: a
|
||||
integer :: res
|
||||
res = a%irp(a%m+1)-1
|
||||
res = a%irp(a%get_nrows()+1)-1
|
||||
end function d_cxx_get_nzeros
|
||||
|
||||
function d_cxx_get_size(a) result(res)
|
||||
@@ -272,6 +314,26 @@ contains
|
||||
|
||||
end function d_cxx_get_size
|
||||
|
||||
|
||||
|
||||
function d_cxx_get_nz_row(idx,a) result(res)
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
|
||||
class(psb_d_cxx_sparse_mat), intent(in) :: a
|
||||
integer, intent(in) :: idx
|
||||
integer :: res
|
||||
|
||||
res = 0
|
||||
|
||||
if ((1<=idx).and.(idx<=a%get_nrows())) then
|
||||
res = a%irp(idx+1)-a%irp(idx)
|
||||
end if
|
||||
|
||||
end function d_cxx_get_nz_row
|
||||
|
||||
|
||||
|
||||
!=====================================
|
||||
!
|
||||
!
|
||||
@@ -299,7 +361,8 @@ contains
|
||||
|
||||
call psb_realloc(nz,a%ja,info)
|
||||
if (info == 0) call psb_realloc(nz,a%val,info)
|
||||
if (info == 0) call psb_realloc(max(nz,a%m+1,a%n+1),a%irp,info)
|
||||
if (info == 0) call psb_realloc(&
|
||||
& max(nz,a%get_nrows()+1,a%get_ncols()+1),a%irp,info)
|
||||
if (info /= 0) then
|
||||
call psb_errpush(4000,name)
|
||||
goto 9999
|
||||
@@ -382,6 +445,49 @@ contains
|
||||
return
|
||||
end subroutine d_cxx_csput
|
||||
|
||||
subroutine d_cxx_csgetptn(imin,imax,a,nz,ia,ja,info,&
|
||||
& jmin,jmax,iren,append,nzin,rscale,cscale)
|
||||
! Output is always in COO format
|
||||
use psb_error_mod
|
||||
use psb_const_mod
|
||||
implicit none
|
||||
|
||||
class(psb_d_cxx_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
|
||||
Integer :: err_act
|
||||
character(len=20) :: name='csget'
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = 0
|
||||
|
||||
call d_cxx_csgetptn_impl(imin,imax,a,nz,ia,ja,info,&
|
||||
& jmin,jmax,iren,append,nzin,rscale,cscale)
|
||||
|
||||
if (info /= 0) 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 d_cxx_csgetptn
|
||||
|
||||
|
||||
subroutine d_cxx_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
|
||||
& jmin,jmax,iren,append,nzin,rscale,cscale)
|
||||
! Output is always in COO format
|
||||
@@ -591,6 +697,55 @@ contains
|
||||
|
||||
end subroutine d_cxx_free
|
||||
|
||||
subroutine d_cxx_reinit(a,clear)
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
class(psb_d_cxx_sparse_mat), intent(inout) :: a
|
||||
logical, intent(in), optional :: clear
|
||||
|
||||
Integer :: err_act, info
|
||||
character(len=20) :: name='reinit'
|
||||
logical :: clear_
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = 0
|
||||
|
||||
|
||||
if (present(clear)) then
|
||||
clear_ = clear
|
||||
else
|
||||
clear_ = .true.
|
||||
end if
|
||||
|
||||
if (a%is_bld() .or. a%is_upd()) then
|
||||
! do nothing
|
||||
return
|
||||
else if (a%is_asb()) then
|
||||
if (clear_) a%val(:) = dzero
|
||||
call a%set_upd()
|
||||
else
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
end if
|
||||
|
||||
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 d_cxx_reinit
|
||||
|
||||
|
||||
subroutine d_cxx_trim(a)
|
||||
use psb_realloc_mod
|
||||
use psb_error_mod
|
||||
@@ -927,6 +1082,7 @@ contains
|
||||
call a%set_ncols(n)
|
||||
call a%set_bld()
|
||||
call a%set_triangle(.false.)
|
||||
call a%set_unit(.false.)
|
||||
end if
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
@@ -1025,6 +1181,81 @@ contains
|
||||
end subroutine d_cxx_print
|
||||
|
||||
|
||||
subroutine d_cxx_cp_from(a,b)
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
class(psb_d_cxx_sparse_mat), intent(out) :: a
|
||||
type(psb_d_cxx_sparse_mat), intent(in) :: b
|
||||
|
||||
|
||||
Integer :: err_act, info
|
||||
character(len=20) :: name='cp_from'
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
|
||||
info = 0
|
||||
|
||||
call a%allocate(b%get_nrows(),b%get_ncols(),b%get_nzeros())
|
||||
call a%psb_d_base_sparse_mat%cp_from(b%psb_d_base_sparse_mat)
|
||||
a%irp = b%irp
|
||||
a%ja = b%ja
|
||||
a%val = b%val
|
||||
|
||||
if (info /= 0) goto 9999
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
|
||||
call psb_errpush(info,name)
|
||||
|
||||
if (err_act /= psb_act_ret_) then
|
||||
call psb_error()
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine d_cxx_cp_from
|
||||
|
||||
subroutine d_cxx_mv_from(a,b)
|
||||
use psb_error_mod
|
||||
implicit none
|
||||
|
||||
class(psb_d_cxx_sparse_mat), intent(out) :: a
|
||||
type(psb_d_cxx_sparse_mat), intent(inout) :: b
|
||||
|
||||
|
||||
Integer :: err_act, info
|
||||
character(len=20) :: name='mv_from'
|
||||
logical, parameter :: debug=.false.
|
||||
|
||||
call psb_erractionsave(err_act)
|
||||
info = 0
|
||||
call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat)
|
||||
call move_alloc(b%irp, a%irp)
|
||||
call move_alloc(b%ja, a%ja)
|
||||
call move_alloc(b%val, a%val)
|
||||
call b%free()
|
||||
|
||||
call psb_erractionrestore(err_act)
|
||||
return
|
||||
|
||||
9999 continue
|
||||
call psb_erractionrestore(err_act)
|
||||
|
||||
call psb_errpush(info,name)
|
||||
|
||||
if (err_act /= psb_act_ret_) then
|
||||
call psb_error()
|
||||
end if
|
||||
return
|
||||
|
||||
end subroutine d_cxx_mv_from
|
||||
|
||||
|
||||
|
||||
!=====================================
|
||||
!
|
||||
!
|
||||
@@ -1151,7 +1382,6 @@ contains
|
||||
|
||||
|
||||
if (.not. (a%is_triangle())) then
|
||||
write(0,*) 'Called SM on a non-triangular mat!'
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
@@ -1205,7 +1435,6 @@ contains
|
||||
|
||||
|
||||
if (.not. (a%is_triangle())) then
|
||||
write(0,*) 'Called SM on a non-triangular mat!'
|
||||
info = 1121
|
||||
call psb_errpush(info,name)
|
||||
goto 9999
|
||||
|
||||
Reference in New Issue
Block a user