fdurastante/psblas3
1
0
Fork 0
mirror of https://github.com/sfilippone/psblas3.git synced 2026-10-20 12:52:14 +00:00
Code Issues Packages Projects Releases Wiki Activity

psblas3

Browse Source 
base/modules/psb_c_base_vect_mod.f90
 base/modules/psb_c_mat_mod.f90
 base/modules/psb_d_base_vect_mod.f90
 base/modules/psb_d_mat_mod.f90
 base/modules/psb_s_base_mat_mod.f90
 base/modules/psb_s_base_vect_mod.f90
 base/modules/psb_s_mat_mod.f90
 base/modules/psb_z_base_vect_mod.f90
 base/modules/psb_z_mat_mod.f90
 base/serial/impl/psb_c_base_mat_impl.f90
 base/serial/impl/psb_c_coo_impl.f90
 base/serial/impl/psb_c_csc_impl.f90
 base/serial/impl/psb_c_csr_impl.f90
 base/serial/impl/psb_c_mat_impl.F90
 base/serial/impl/psb_d_base_mat_impl.f90
 base/serial/impl/psb_d_coo_impl.f90
 base/serial/impl/psb_d_csc_impl.f90
 base/serial/impl/psb_d_csr_impl.f90
 base/serial/impl/psb_d_mat_impl.F90
 base/serial/impl/psb_s_base_mat_impl.f90
 base/serial/impl/psb_s_coo_impl.f90
 base/serial/impl/psb_s_csc_impl.f90
 base/serial/impl/psb_s_csr_impl.f90
 base/serial/impl/psb_s_mat_impl.F90
 base/serial/impl/psb_z_base_mat_impl.f90
 base/serial/impl/psb_z_coo_impl.f90
 base/serial/impl/psb_z_csc_impl.f90
 base/serial/impl/psb_z_csr_impl.f90
 base/serial/impl/psb_z_mat_impl.F90
 krylov/psb_dbicg.f90
 krylov/psb_dcg.F90
 krylov/psb_dcgs.f90
 krylov/psb_dcgstab.F90
 krylov/psb_dcgstabl.f90
 krylov/psb_dkrylov.f90
 krylov/psb_drgmres.f90
 prec/psb_c_diagprec.f90

Various merges from testpre. To be reviewed
Krylov subspace: take out D version without VECT.
This commit is contained in:
Salvatore Filippone
2011-11-29 09:45:26 +00:00
parent c804941be6
commit 5087a02aaf
37 changed files with 3632 additions and 3388 deletions
Download Patch File Download Diff File Expand all files Collapse all files
base/modules/psb_c_base_vect_mod.f90
+35 -31
View File
@@ -118,12 +118,14 @@ contains
complex(psb_spk_), intent(in) :: val(:)
integer :: nr
integer :: info
if (allocated(x%v)) then
nr = min(size(x%v),size(val))
x%v(1:nr) = val(1:nr)
else
x%v = val
end if
end subroutine c_base_set_vect
@@ -150,23 +152,27 @@ contains
implicit none
class(psb_c_base_vect_type), intent(in) :: x
integer :: res
res = 0
if (allocated(x%v)) res = size(x%v)
end function c_base_get_nrows
function c_base_sizeof(x) result(res)
implicit none
class(psb_c_base_vect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
res = (2*psb_sizeof_sp)*x%get_nrows()
res = (1_psb_long_int_k_ * (2*psb_sizeof_sp)) * x%get_nrows()
end function c_base_sizeof
function c_base_dot_v(n,x,y) result(res)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x, y
integer, intent(in) :: n
complex(psb_spk_) :: res
complex(psb_spk_), external :: cdotc
complex(psb_spk_) :: res
complex(psb_spk_), external :: cdotc
res = czero
!
@@ -186,10 +192,10 @@ contains
function c_base_dot_a(n,x,y) result(res)
implicit none
class(psb_c_base_vect_type), intent(inout) :: x
complex(psb_spk_), intent(in) :: y(:)
complex(psb_spk_), intent(in) :: y(:)
integer, intent(in) :: n
complex(psb_spk_) :: res
complex(psb_spk_), external :: cdotc
complex(psb_spk_) :: res
complex(psb_spk_), external :: cdotc
res = cdotc(n,y,1,x%v,1)
@@ -268,13 +274,11 @@ contains
subroutine c_base_mlt_a_2(alpha,x,y,beta,z,info)
use psi_serial_mod
implicit none
complex(psb_spk_), intent(in) :: alpha,beta
complex(psb_spk_), intent(in) :: y(:)
complex(psb_spk_), intent(in) :: x(:)
class(psb_c_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
! character(len=1), intent(in), optional :: conjgx, conjgy
complex(psb_spk_), intent(in) :: alpha,beta
complex(psb_spk_), intent(in) :: y(:)
complex(psb_spk_), intent(in) :: x(:)
class(psb_c_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
integer :: i, n
info = 0
@@ -339,29 +343,29 @@ contains
use psi_serial_mod
use psb_string_mod
implicit none
complex(psb_spk_), intent(in) :: alpha,beta
class(psb_c_base_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(inout) :: y
class(psb_c_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
complex(psb_spk_), intent(in) :: alpha,beta
class(psb_c_base_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(inout) :: y
class(psb_c_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
character(len=1), intent(in), optional :: conjgx, conjgy
integer :: i, n
logical :: conjgx_, conjgy_
info = 0
if (present(conjgx)) then
if (psb_toupper(conjgx)=='C') x%v=conjg(x%v)
if (.not.psb_c_is_complex_) then
call z%mlt(alpha,x%v,y%v,beta,info)
else
conjgx_=.false.
if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C')
conjgy_=.false.
if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C')
if (conjgx_) x%v=conjg(x%v)
if (conjgy_) y%v=conjg(y%v)
call z%mlt(alpha,x%v,y%v,beta,info)
if (conjgx_) x%v=conjg(x%v)
if (conjgy_) y%v=conjg(y%v)
end if
if (present(conjgy)) then
if (psb_toupper(conjgy)=='C') y%v=conjg(y%v)
end if
call z%mlt(alpha,x%v,y%v,beta,info)
if (present(conjgx)) then
if (psb_toupper(conjgx)=='C') x%v=conjg(x%v)
end if
if (present(conjgy)) then
if (psb_toupper(conjgy)=='C') y%v=conjg(y%v)
end if
end subroutine c_base_mlt_v_2
subroutine c_base_mlt_av(alpha,x,y,beta,z,info)
base/modules/psb_c_mat_mod.f90
+54 -54
View File
@@ -337,9 +337,9 @@ module psb_c_mat_mod
interface
subroutine psb_c_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: val(:)
complex(psb_spk_), intent(in) :: val(:)
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
@@ -349,7 +349,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
@@ -365,12 +365,12 @@ module psb_c_mat_mod
interface
subroutine psb_c_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
integer, allocatable, intent(inout) :: ia(:), ja(:)
complex(psb_dpk_), allocatable, intent(inout) :: val(:)
complex(psb_spk_), allocatable, intent(inout) :: val(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
@@ -382,7 +382,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_csgetblk(imin,imax,a,b,info,&
& jmin,jmax,iren,append,rscale,cscale)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
class(psb_cspmat_type), intent(out) :: b
integer, intent(in) :: imin,imax
@@ -397,7 +397,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
class(psb_cspmat_type), intent(out) :: b
integer,intent(out) :: info
@@ -409,7 +409,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_cspmat_type, psb_dpk_, psb_c_coo_sparse_mat
import :: psb_cspmat_type, psb_spk_, psb_c_coo_sparse_mat
class(psb_cspmat_type), intent(in) :: a
type(psb_c_coo_sparse_mat), intent(out) :: b
integer,intent(out) :: info
@@ -420,7 +420,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl)
import :: psb_cspmat_type, psb_dpk_, psb_c_base_sparse_mat
import :: psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(in) :: a
class(psb_cspmat_type), intent(out) :: b
integer, intent(out) :: info
@@ -433,7 +433,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_cscnv_ip(a,iinfo,type,mold,dupl)
import :: psb_cspmat_type, psb_dpk_, psb_c_base_sparse_mat
import :: psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(inout) :: a
integer, intent(out) :: iinfo
integer,optional, intent(in) :: dupl
@@ -445,7 +445,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_cscnv_base(a,b,info,dupl)
import :: psb_cspmat_type, psb_dpk_, psb_c_base_sparse_mat
import :: psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(in) :: a
class(psb_c_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
@@ -472,7 +472,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_mv_from(a,b)
import :: psb_cspmat_type, psb_dpk_, psb_c_base_sparse_mat
import :: psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(out) :: a
class(psb_c_base_sparse_mat), intent(inout) :: b
end subroutine psb_c_mv_from
@@ -480,7 +480,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_cp_from(a,b)
import :: psb_cspmat_type, psb_dpk_, psb_c_base_sparse_mat
import :: psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(out) :: a
class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
end subroutine psb_c_cp_from
@@ -488,7 +488,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_mv_to(a,b)
import :: psb_cspmat_type, psb_dpk_, psb_c_base_sparse_mat
import :: psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(inout) :: a
class(psb_c_base_sparse_mat), intent(out) :: b
end subroutine psb_c_mv_to
@@ -496,7 +496,7 @@ module psb_c_mat_mod
interface
subroutine psb_c_cp_to(a,b)
import :: psb_cspmat_type, psb_dpk_, psb_c_base_sparse_mat
import :: psb_cspmat_type, psb_spk_, psb_c_base_sparse_mat
class(psb_cspmat_type), intent(in) :: a
class(psb_c_base_sparse_mat), intent(out) :: b
end subroutine psb_c_cp_to
@@ -584,26 +584,26 @@ module psb_c_mat_mod
interface psb_csmm
subroutine psb_c_csmm(alpha,a,x,beta,y,info,trans)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
complex(psb_dpk_), intent(inout) :: y(:,:)
complex(psb_spk_), intent(in) :: alpha, beta, x(:,:)
complex(psb_spk_), intent(inout) :: y(:,:)
integer, intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_c_csmm
subroutine psb_c_csmv(alpha,a,x,beta,y,info,trans)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta, x(:)
complex(psb_dpk_), intent(inout) :: y(:)
complex(psb_spk_), intent(in) :: alpha, beta, x(:)
complex(psb_spk_), intent(inout) :: y(:)
integer, intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_c_csmv
subroutine psb_c_csmv_vect(alpha,a,x,beta,y,info,trans)
use psb_c_vect_mod, only : psb_c_vect_type
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta
complex(psb_spk_), intent(in) :: alpha, beta
type(psb_c_vect_type), intent(inout) :: x
type(psb_c_vect_type), intent(inout) :: y
integer, intent(out) :: info
@@ -613,28 +613,28 @@ module psb_c_mat_mod
interface psb_cssm
subroutine psb_c_cssm(alpha,a,x,beta,y,info,trans,scale,d)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
complex(psb_dpk_), intent(inout) :: y(:,:)
complex(psb_spk_), intent(in) :: alpha, beta, x(:,:)
complex(psb_spk_), intent(inout) :: y(:,:)
integer, intent(out) :: info
character, optional, intent(in) :: trans, scale
complex(psb_dpk_), intent(in), optional :: d(:)
complex(psb_spk_), intent(in), optional :: d(:)
end subroutine psb_c_cssm
subroutine psb_c_cssv(alpha,a,x,beta,y,info,trans,scale,d)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta, x(:)
complex(psb_dpk_), intent(inout) :: y(:)
complex(psb_spk_), intent(in) :: alpha, beta, x(:)
complex(psb_spk_), intent(inout) :: y(:)
integer, intent(out) :: info
character, optional, intent(in) :: trans, scale
complex(psb_dpk_), intent(in), optional :: d(:)
complex(psb_spk_), intent(in), optional :: d(:)
end subroutine psb_c_cssv
subroutine psb_c_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d)
use psb_c_vect_mod, only : psb_c_vect_type
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta
complex(psb_spk_), intent(in) :: alpha, beta
type(psb_c_vect_type), intent(inout) :: x
type(psb_c_vect_type), intent(inout) :: y
integer, intent(out) :: info
@@ -645,85 +645,85 @@ module psb_c_mat_mod
interface
function psb_c_maxval(a) result(res)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
real(psb_dpk_) :: res
real(psb_spk_) :: res
end function psb_c_maxval
end interface
interface
function psb_c_csnmi(a) result(res)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
real(psb_dpk_) :: res
real(psb_spk_) :: res
end function psb_c_csnmi
end interface
interface
function psb_c_csnm1(a) result(res)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
real(psb_dpk_) :: res
real(psb_spk_) :: res
end function psb_c_csnm1
end interface
interface
subroutine psb_c_rowsum(d,a,info)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
complex(psb_dpk_), intent(out) :: d(:)
complex(psb_spk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_c_rowsum
end interface
interface
subroutine psb_c_arwsum(d,a,info)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
real(psb_spk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_c_arwsum
end interface
interface
subroutine psb_c_colsum(d,a,info)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
complex(psb_dpk_), intent(out) :: d(:)
complex(psb_spk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_c_colsum
end interface
interface
subroutine psb_c_aclsum(d,a,info)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
integer, intent(out) :: info
real(psb_spk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_c_aclsum
end interface
interface
subroutine psb_c_get_diag(a,d,info)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(in) :: a
complex(psb_dpk_), intent(out) :: d(:)
complex(psb_spk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_c_get_diag
end interface
interface psb_scal
subroutine psb_c_scal(d,a,info)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: d(:)
complex(psb_spk_), intent(in) :: d(:)
integer, intent(out) :: info
end subroutine psb_c_scal
subroutine psb_c_scals(d,a,info)
import :: psb_cspmat_type, psb_dpk_
import :: psb_cspmat_type, psb_spk_
class(psb_cspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: d
complex(psb_spk_), intent(in) :: d
integer, intent(out) :: info
end subroutine psb_c_scals
end interface
base/modules/psb_d_base_vect_mod.f90
+30 -20
View File
@@ -76,7 +76,7 @@ contains
integer, intent(in) :: n
class(psb_d_base_vect_type), intent(inout) :: x
integer :: info
call psb_realloc(n,x%v,info)
call x%asb(n,info)
@@ -118,12 +118,14 @@ contains
real(psb_dpk_), intent(in) :: val(:)
integer :: nr
integer :: info
if (allocated(x%v)) then
nr = min(size(x%v),size(val))
x%v(1:nr) = val(1:nr)
else
x%v = val
end if
end subroutine d_base_set_vect
@@ -150,15 +152,19 @@ contains
implicit none
class(psb_d_base_vect_type), intent(in) :: x
integer :: res
res = 0
if (allocated(x%v)) res = size(x%v)
end function d_base_get_nrows
function d_base_sizeof(x) result(res)
implicit none
class(psb_d_base_vect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
res = psb_sizeof_dp*x%get_nrows()
res = (1_psb_long_int_k_ * psb_sizeof_dp) * x%get_nrows()
end function d_base_sizeof
function d_base_dot_v(n,x,y) result(res)
@@ -227,24 +233,15 @@ contains
end subroutine d_base_axpby_a
subroutine d_base_mlt_v(x, y, info, xconj)
subroutine d_base_mlt_v(x, y, info)
use psi_serial_mod
use psb_string_mod
implicit none
class(psb_d_base_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
character, intent(in), optional :: xconj
integer :: i, n
character :: xconj_
class(psb_d_base_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
integer :: i, n
info = 0
if (present(xconj)) then
xconj_ = (psb_toupper(xconj))
else
xconj_ = 'N'
end if
select type(xx => x)
type is (psb_d_base_vect_type)
n = min(size(y%v), size(xx%v))
@@ -342,20 +339,33 @@ contains
end if
end subroutine d_base_mlt_a_2
subroutine d_base_mlt_v_2(alpha,x,y,beta,z,info)
subroutine d_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
use psi_serial_mod
use psb_string_mod
implicit none
real(psb_dpk_), intent(in) :: alpha,beta
class(psb_d_base_vect_type), intent(inout) :: x
class(psb_d_base_vect_type), intent(inout) :: y
class(psb_d_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
character(len=1), intent(in), optional :: conjgx, conjgy
integer :: i, n
logical :: conjgx_, conjgy_
info = 0
call z%mlt(alpha,x%v,y%v,beta,info)
if (.not.psb_d_is_complex_) then
call z%mlt(alpha,x%v,y%v,beta,info)
else
conjgx_=.false.
if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C')
conjgy_=.false.
if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C')
if (conjgx_) x%v=(x%v)
if (conjgy_) y%v=(y%v)
call z%mlt(alpha,x%v,y%v,beta,info)
if (conjgx_) x%v=(x%v)
if (conjgy_) y%v=(y%v)
end if
end subroutine d_base_mlt_v_2
subroutine d_base_mlt_av(alpha,x,y,beta,z,info)
base/modules/psb_d_mat_mod.f90
+4 -4
View File
@@ -699,7 +699,7 @@ module psb_d_mat_mod
import :: psb_dspmat_type, psb_dpk_
class(psb_dspmat_type), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
integer, intent(out) :: info
integer, intent(out) :: info
end subroutine psb_d_aclsum
end interface
@@ -708,7 +708,7 @@ module psb_d_mat_mod
subroutine psb_d_get_diag(a,d,info)
import :: psb_dspmat_type, psb_dpk_
class(psb_dspmat_type), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
real(psb_dpk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_d_get_diag
end interface
@@ -717,13 +717,13 @@ module psb_d_mat_mod
subroutine psb_d_scal(d,a,info)
import :: psb_dspmat_type, psb_dpk_
class(psb_dspmat_type), intent(inout) :: a
real(psb_dpk_), intent(in) :: d(:)
real(psb_dpk_), intent(in) :: d(:)
integer, intent(out) :: info
end subroutine psb_d_scal
subroutine psb_d_scals(d,a,info)
import :: psb_dspmat_type, psb_dpk_
class(psb_dspmat_type), intent(inout) :: a
real(psb_dpk_), intent(in) :: d
real(psb_dpk_), intent(in) :: d
integer, intent(out) :: info
end subroutine psb_d_scals
end interface
base/modules/psb_s_base_mat_mod.f90
+30 -26
View File
@@ -32,13 +32,13 @@
!
! package: psb_s_base_mat_mod
!
! This module contains the implementation of the
! psb_s_base_sparse_mat, derived from the psb_base_sparse_mat to
! define a middle level definition of a real, single-precision sparse
! matrix object.This class object itself does not have any additional
! members with respect to those of the base class. No methods can be
! fully implemented at this level, but we can define the interface for
! the computational methods requiring the knowledge of the underlying
! This module contains the implementation of the psb_s_base_sparse_mat
! type, derived from the psb_base_sparse_mat one to define a middle
! level definition of a real(psb_spk_) sparse matrix
! object.This class object itself does not have any additional members
! with respect to those of the base class. No methods can be fully
! implemented at this level, but we can define the interface for the
! computational methods requiring the knowledge of the underlying
! field, such as the matrix-vector product; this interface is defined,
! but is supposed to be overridden at the leaf level.
!
@@ -50,11 +50,9 @@
! psb_s_base_sparse_mat one.
!
! About the method MOLD: this has been defined for those compilers
! not yet supporting ALLOCATE( ...MOLD=...); it's otherwise silly to
! not yet supporting ALLOCATE( ...,MOLD=...); it's otherwise silly to
! duplicate "by hand" what is specified in the language (in this case F2008)
!
module psb_s_base_mat_mod
use psb_base_mat_mod
@@ -134,13 +132,6 @@ module psb_s_base_mat_mod
procedure, pass(a) :: s_inner_cssv => psb_s_coo_cssv
procedure, pass(a) :: s_scals => psb_s_coo_scals
procedure, pass(a) :: s_scal => psb_s_coo_scal
procedure, pass(a) :: maxval => psb_s_coo_maxval
procedure, pass(a) :: csnmi => psb_s_coo_csnmi
procedure, pass(a) :: csnm1 => psb_s_coo_csnm1
procedure, pass(a) :: rowsum => psb_s_coo_rowsum
procedure, pass(a) :: arwsum => psb_s_coo_arwsum
procedure, pass(a) :: colsum => psb_s_coo_colsum
procedure, pass(a) :: aclsum => psb_s_coo_aclsum
procedure, pass(a) :: reallocate_nz => psb_s_coo_reallocate_nz
procedure, pass(a) :: allocate_mnnz => psb_s_coo_allocate_mnnz
procedure, pass(a) :: cp_to_coo => psb_s_cp_coo_to_coo
@@ -152,6 +143,13 @@ module psb_s_base_mat_mod
procedure, pass(a) :: mv_to_fmt => psb_s_mv_coo_to_fmt
procedure, pass(a) :: mv_from_fmt => psb_s_mv_coo_from_fmt
procedure, pass(a) :: csput => psb_s_coo_csput
procedure, pass(a) :: maxval => psb_s_coo_maxval
procedure, pass(a) :: csnmi => psb_s_coo_csnmi
procedure, pass(a) :: csnm1 => psb_s_coo_csnm1
procedure, pass(a) :: rowsum => psb_s_coo_rowsum
procedure, pass(a) :: arwsum => psb_s_coo_arwsum
procedure, pass(a) :: colsum => psb_s_coo_colsum
procedure, pass(a) :: aclsum => psb_s_coo_aclsum
procedure, pass(a) :: get_diag => psb_s_coo_get_diag
procedure, pass(a) :: s_csgetrow => psb_s_coo_csgetrow
procedure, pass(a) :: csgetptn => psb_s_coo_csgetptn
@@ -217,7 +215,7 @@ module psb_s_base_mat_mod
character, optional, intent(in) :: trans
end subroutine psb_s_base_vect_mv
end interface
interface
subroutine psb_s_base_inner_cssm(alpha,a,x,beta,y,info,trans)
import :: psb_s_base_sparse_mat, psb_spk_
@@ -312,7 +310,7 @@ module psb_s_base_mat_mod
real(psb_spk_) :: res
end function psb_s_base_maxval
end interface
interface
function psb_s_base_csnmi(a) result(res)
import :: psb_s_base_sparse_mat, psb_spk_
@@ -360,7 +358,7 @@ module psb_s_base_mat_mod
real(psb_spk_), intent(out) :: d(:)
end subroutine psb_s_base_aclsum
end interface
interface
subroutine psb_s_base_get_diag(a,d,info)
import :: psb_s_base_sparse_mat, psb_spk_
@@ -512,7 +510,7 @@ module psb_s_base_mat_mod
subroutine psb_s_base_transp_2mat(a,b)
import :: psb_s_base_sparse_mat, psb_base_sparse_mat, psb_spk_
class(psb_s_base_sparse_mat), intent(in) :: a
class(psb_base_sparse_mat), intent(out) :: b
class(psb_base_sparse_mat), intent(out) :: b
end subroutine psb_s_base_transp_2mat
end interface
@@ -520,7 +518,7 @@ module psb_s_base_mat_mod
subroutine psb_s_base_transc_2mat(a,b)
import :: psb_s_base_sparse_mat, psb_base_sparse_mat, psb_spk_
class(psb_s_base_sparse_mat), intent(in) :: a
class(psb_base_sparse_mat), intent(out) :: b
class(psb_base_sparse_mat), intent(out) :: b
end subroutine psb_s_base_transc_2mat
end interface
@@ -578,7 +576,7 @@ module psb_s_base_mat_mod
integer, intent(in), optional :: nz
end subroutine psb_s_coo_allocate_mnnz
end interface
interface
subroutine psb_s_coo_mold(a,b,info)
import :: psb_s_coo_sparse_mat, psb_s_base_sparse_mat, psb_long_int_k_
@@ -588,6 +586,7 @@ module psb_s_base_mat_mod
end subroutine psb_s_coo_mold
end interface
interface
subroutine psb_s_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc)
import :: psb_s_coo_sparse_mat
@@ -621,7 +620,7 @@ module psb_s_base_mat_mod
integer, intent(in), optional :: idir
end subroutine psb_s_fix_coo_inner
end interface
interface
subroutine psb_s_fix_coo(a,info,idir)
import :: psb_s_coo_sparse_mat
@@ -803,7 +802,7 @@ module psb_s_base_mat_mod
end subroutine psb_s_coo_csmm
end interface
interface
function psb_s_coo_maxval(a) result(res)
import :: psb_s_coo_sparse_mat, psb_spk_
@@ -811,7 +810,7 @@ module psb_s_base_mat_mod
real(psb_spk_) :: res
end function psb_s_coo_maxval
end interface
interface
function psb_s_coo_csnmi(a) result(res)
import :: psb_s_coo_sparse_mat, psb_spk_
@@ -1076,6 +1075,11 @@ contains
class(psb_s_coo_sparse_mat), intent(inout) :: a
call a%transp()
! This will morph into conjg() for C and Z
! and into a no-op for S and D, so a conditional
! on a constant ought to take it out completely.
if (psb_s_is_complex_) a%val(:) = (a%val(:))
end subroutine s_coo_transc_1mat
base/modules/psb_s_base_vect_mod.f90
+25 -6
View File
@@ -118,12 +118,14 @@ contains
real(psb_spk_), intent(in) :: val(:)
integer :: nr
integer :: info
if (allocated(x%v)) then
nr = min(size(x%v),size(val))
x%v(1:nr) = val(1:nr)
else
x%v = val
end if
end subroutine s_base_set_vect
@@ -150,15 +152,19 @@ contains
implicit none
class(psb_s_base_vect_type), intent(in) :: x
integer :: res
res = 0
if (allocated(x%v)) res = size(x%v)
end function s_base_get_nrows
function s_base_sizeof(x) result(res)
implicit none
class(psb_s_base_vect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
res = psb_sizeof_sp*x%get_nrows()
res = (1_psb_long_int_k_ * psb_sizeof_sp) * x%get_nrows()
end function s_base_sizeof
function s_base_dot_v(n,x,y) result(res)
@@ -333,20 +339,33 @@ contains
end if
end subroutine s_base_mlt_a_2
subroutine s_base_mlt_v_2(alpha,x,y,beta,z,info)
subroutine s_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
use psi_serial_mod
use psb_string_mod
implicit none
real(psb_spk_), intent(in) :: alpha,beta
class(psb_s_base_vect_type), intent(inout) :: x
class(psb_s_base_vect_type), intent(inout) :: y
class(psb_s_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
character(len=1), intent(in), optional :: conjgx, conjgy
integer :: i, n
logical :: conjgx_, conjgy_
info = 0
call z%mlt(alpha,x%v,y%v,beta,info)
if (.not.psb_s_is_complex_) then
call z%mlt(alpha,x%v,y%v,beta,info)
else
conjgx_=.false.
if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C')
conjgy_=.false.
if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C')
if (conjgx_) x%v=(x%v)
if (conjgy_) y%v=(y%v)
call z%mlt(alpha,x%v,y%v,beta,info)
if (conjgx_) x%v=(x%v)
if (conjgy_) y%v=(y%v)
end if
end subroutine s_base_mlt_v_2
subroutine s_base_mlt_av(alpha,x,y,beta,z,info)
base/modules/psb_s_mat_mod.f90
+54 -54
View File
@@ -337,9 +337,9 @@ module psb_s_mat_mod
interface
subroutine psb_s_csput(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(inout) :: a
real(psb_dpk_), intent(in) :: val(:)
real(psb_spk_), intent(in) :: val(:)
integer, intent(in) :: nz, ia(:), ja(:), imin,imax,jmin,jmax
integer, intent(out) :: info
integer, intent(in), optional :: gtl(:)
@@ -349,7 +349,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_csgetptn(imin,imax,a,nz,ia,ja,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
integer, intent(in) :: imin,imax
integer, intent(out) :: nz
@@ -365,12 +365,12 @@ module psb_s_mat_mod
interface
subroutine psb_s_csgetrow(imin,imax,a,nz,ia,ja,val,info,&
& jmin,jmax,iren,append,nzin,rscale,cscale)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), 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(:)
real(psb_spk_), allocatable, intent(inout) :: val(:)
integer,intent(out) :: info
logical, intent(in), optional :: append
integer, intent(in), optional :: iren(:)
@@ -382,7 +382,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_csgetblk(imin,imax,a,b,info,&
& jmin,jmax,iren,append,rscale,cscale)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
class(psb_sspmat_type), intent(out) :: b
integer, intent(in) :: imin,imax
@@ -397,7 +397,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
class(psb_sspmat_type), intent(out) :: b
integer,intent(out) :: info
@@ -409,7 +409,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_b_csclip(a,b,info,&
& imin,imax,jmin,jmax,rscale,cscale)
import :: psb_sspmat_type, psb_dpk_, psb_s_coo_sparse_mat
import :: psb_sspmat_type, psb_spk_, psb_s_coo_sparse_mat
class(psb_sspmat_type), intent(in) :: a
type(psb_s_coo_sparse_mat), intent(out) :: b
integer,intent(out) :: info
@@ -420,7 +420,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl)
import :: psb_sspmat_type, psb_dpk_, psb_s_base_sparse_mat
import :: psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(in) :: a
class(psb_sspmat_type), intent(out) :: b
integer, intent(out) :: info
@@ -433,7 +433,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_cscnv_ip(a,iinfo,type,mold,dupl)
import :: psb_sspmat_type, psb_dpk_, psb_s_base_sparse_mat
import :: psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(inout) :: a
integer, intent(out) :: iinfo
integer,optional, intent(in) :: dupl
@@ -445,7 +445,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_cscnv_base(a,b,info,dupl)
import :: psb_sspmat_type, psb_dpk_, psb_s_base_sparse_mat
import :: psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(in) :: a
class(psb_s_base_sparse_mat), intent(out) :: b
integer, intent(out) :: info
@@ -472,7 +472,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_mv_from(a,b)
import :: psb_sspmat_type, psb_dpk_, psb_s_base_sparse_mat
import :: psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(out) :: a
class(psb_s_base_sparse_mat), intent(inout) :: b
end subroutine psb_s_mv_from
@@ -480,7 +480,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_cp_from(a,b)
import :: psb_sspmat_type, psb_dpk_, psb_s_base_sparse_mat
import :: psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(out) :: a
class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
end subroutine psb_s_cp_from
@@ -488,7 +488,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_mv_to(a,b)
import :: psb_sspmat_type, psb_dpk_, psb_s_base_sparse_mat
import :: psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(inout) :: a
class(psb_s_base_sparse_mat), intent(out) :: b
end subroutine psb_s_mv_to
@@ -496,7 +496,7 @@ module psb_s_mat_mod
interface
subroutine psb_s_cp_to(a,b)
import :: psb_sspmat_type, psb_dpk_, psb_s_base_sparse_mat
import :: psb_sspmat_type, psb_spk_, psb_s_base_sparse_mat
class(psb_sspmat_type), intent(in) :: a
class(psb_s_base_sparse_mat), intent(out) :: b
end subroutine psb_s_cp_to
@@ -584,26 +584,26 @@ module psb_s_mat_mod
interface psb_csmm
subroutine psb_s_csmm(alpha,a,x,beta,y,info,trans)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
real(psb_spk_), intent(in) :: alpha, beta, x(:,:)
real(psb_spk_), intent(inout) :: y(:,:)
integer, intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_s_csmm
subroutine psb_s_csmv(alpha,a,x,beta,y,info,trans)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
real(psb_spk_), intent(in) :: alpha, beta, x(:)
real(psb_spk_), intent(inout) :: y(:)
integer, intent(out) :: info
character, optional, intent(in) :: trans
end subroutine psb_s_csmv
subroutine psb_s_csmv_vect(alpha,a,x,beta,y,info,trans)
use psb_s_vect_mod, only : psb_s_vect_type
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta
real(psb_spk_), intent(in) :: alpha, beta
type(psb_s_vect_type), intent(inout) :: x
type(psb_s_vect_type), intent(inout) :: y
integer, intent(out) :: info
@@ -613,28 +613,28 @@ module psb_s_mat_mod
interface psb_cssm
subroutine psb_s_cssm(alpha,a,x,beta,y,info,trans,scale,d)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:,:)
real(psb_dpk_), intent(inout) :: y(:,:)
real(psb_spk_), intent(in) :: alpha, beta, x(:,:)
real(psb_spk_), intent(inout) :: y(:,:)
integer, intent(out) :: info
character, optional, intent(in) :: trans, scale
real(psb_dpk_), intent(in), optional :: d(:)
real(psb_spk_), intent(in), optional :: d(:)
end subroutine psb_s_cssm
subroutine psb_s_cssv(alpha,a,x,beta,y,info,trans,scale,d)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta, x(:)
real(psb_dpk_), intent(inout) :: y(:)
real(psb_spk_), intent(in) :: alpha, beta, x(:)
real(psb_spk_), intent(inout) :: y(:)
integer, intent(out) :: info
character, optional, intent(in) :: trans, scale
real(psb_dpk_), intent(in), optional :: d(:)
real(psb_spk_), intent(in), optional :: d(:)
end subroutine psb_s_cssv
subroutine psb_s_cssv_vect(alpha,a,x,beta,y,info,trans,scale,d)
use psb_s_vect_mod, only : psb_s_vect_type
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(in) :: alpha, beta
real(psb_spk_), intent(in) :: alpha, beta
type(psb_s_vect_type), intent(inout) :: x
type(psb_s_vect_type), intent(inout) :: y
integer, intent(out) :: info
@@ -645,85 +645,85 @@ module psb_s_mat_mod
interface
function psb_s_maxval(a) result(res)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_) :: res
real(psb_spk_) :: res
end function psb_s_maxval
end interface
interface
function psb_s_csnmi(a) result(res)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_) :: res
real(psb_spk_) :: res
end function psb_s_csnmi
end interface
interface
function psb_s_csnm1(a) result(res)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_) :: res
real(psb_spk_) :: res
end function psb_s_csnm1
end interface
interface
subroutine psb_s_rowsum(d,a,info)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
real(psb_spk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_s_rowsum
end interface
interface
subroutine psb_s_arwsum(d,a,info)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
real(psb_spk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_s_arwsum
end interface
interface
subroutine psb_s_colsum(d,a,info)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
real(psb_spk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_s_colsum
end interface
interface
subroutine psb_s_aclsum(d,a,info)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
integer, intent(out) :: info
real(psb_spk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_s_aclsum
end interface
interface
subroutine psb_s_get_diag(a,d,info)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
real(psb_spk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_s_get_diag
end interface
interface psb_scal
subroutine psb_s_scal(d,a,info)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(inout) :: a
real(psb_dpk_), intent(in) :: d(:)
real(psb_spk_), intent(in) :: d(:)
integer, intent(out) :: info
end subroutine psb_s_scal
subroutine psb_s_scals(d,a,info)
import :: psb_sspmat_type, psb_dpk_
import :: psb_sspmat_type, psb_spk_
class(psb_sspmat_type), intent(inout) :: a
real(psb_dpk_), intent(in) :: d
real(psb_spk_), intent(in) :: d
integer, intent(out) :: info
end subroutine psb_s_scals
end interface
base/modules/psb_z_base_vect_mod.f90
+64 -92
View File
@@ -118,14 +118,15 @@ contains
complex(psb_dpk_), intent(in) :: val(:)
integer :: nr
integer :: info
if (allocated(x%v)) then
nr = min(size(x%v),size(val))
x%v(1:nr) = val(1:nr)
else
x%v = val
end if
end subroutine z_base_set_vect
end subroutine z_base_set_vect
function constructor(x) result(this)
@@ -151,23 +152,27 @@ contains
implicit none
class(psb_z_base_vect_type), intent(in) :: x
integer :: res
res = 0
if (allocated(x%v)) res = size(x%v)
end function z_base_get_nrows
function z_base_sizeof(x) result(res)
implicit none
class(psb_z_base_vect_type), intent(in) :: x
integer(psb_long_int_k_) :: res
res = (2*psb_sizeof_dp)*x%get_nrows()
res = (1_psb_long_int_k_ * (2*psb_sizeof_dp)) * x%get_nrows()
end function z_base_sizeof
function z_base_dot_v(n,x,y) result(res)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x, y
integer, intent(in) :: n
complex(psb_dpk_) :: res
complex(psb_dpk_), external :: zdotc
complex(psb_dpk_) :: res
complex(psb_dpk_), external :: zdotc
res = zzero
!
@@ -187,10 +192,10 @@ contains
function z_base_dot_a(n,x,y) result(res)
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
complex(psb_dpk_), intent(in) :: y(:)
complex(psb_dpk_), intent(in) :: y(:)
integer, intent(in) :: n
complex(psb_dpk_) :: res
complex(psb_dpk_), external :: zdotc
complex(psb_dpk_) :: res
complex(psb_dpk_), external :: zdotc
res = zdotc(n,y,1,x%v,1)
@@ -202,7 +207,7 @@ contains
integer, intent(in) :: m
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: y
complex(psb_dpk_), intent (in) :: alpha, beta
complex(psb_dpk_), intent (in) :: alpha, beta
integer, intent(out) :: info
select type(xx => x)
@@ -228,72 +233,41 @@ contains
end subroutine z_base_axpby_a
subroutine z_base_mlt_v(x, y, info, xconj)
subroutine z_base_mlt_v(x, y, info)
use psi_serial_mod
use psb_string_mod
implicit none
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
character, intent(in), optional :: xconj
integer :: i, n
character :: xconj_
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
integer :: i, n
info = 0
if (present(xconj)) then
xconj_ = (psb_toupper(xconj))
else
xconj_ = 'N'
end if
select type(xx => x)
type is (psb_z_base_vect_type)
n = min(size(y%v), size(xx%v))
select case (xconj_)
case ('C')
do i=1, n
y%v(i) = y%v(i)*conjg(xx%v(i))
end do
case default
do i=1, n
y%v(i) = y%v(i)*xx%v(i)
end do
end select
do i=1, n
y%v(i) = y%v(i)*xx%v(i)
end do
class default
call y%mlt(x%v,info,xconj)
call y%mlt(x%v,info)
end select
end subroutine z_base_mlt_v
subroutine z_base_mlt_a(x, y, info, xconj)
subroutine z_base_mlt_a(x, y, info)
use psi_serial_mod
use psb_string_mod
implicit none
complex(psb_dpk_), intent(in) :: x(:)
class(psb_z_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
character, intent(in), optional :: xconj
character :: xconj_
complex(psb_dpk_), intent(in) :: x(:)
class(psb_z_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
integer :: i, n
info = 0
if (present(xconj)) then
xconj_ = (psb_toupper(xconj))
else
xconj_ = 'N'
end if
n = min(size(y%v), size(x))
select case (xconj_)
case ('C')
do i=1, n
y%v(i) = y%v(i)*conjg(x(i))
end do
case default
do i=1, n
y%v(i) = y%v(i)*x(i)
end do
end select
do i=1, n
y%v(i) = y%v(i)*x(i)
end do
end subroutine z_base_mlt_a
@@ -365,44 +339,43 @@ contains
end if
end subroutine z_base_mlt_a_2
subroutine z_base_mlt_v_2(alpha,x,y,beta,z,info,xconj,yconj)
subroutine z_base_mlt_v_2(alpha,x,y,beta,z,info,conjgx,conjgy)
use psi_serial_mod
use psb_string_mod
implicit none
complex(psb_dpk_), intent(in) :: alpha,beta
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: y
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
character(len=1), intent(in), optional :: xconj, yconj
complex(psb_dpk_), intent(in) :: alpha,beta
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: y
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
character(len=1), intent(in), optional :: conjgx, conjgy
integer :: i, n
logical :: conjgx_, conjgy_
info = 0
if (present(xconj)) then
if (psb_toupper(xconj)=='C') x%v=conjg(x%v)
if (.not.psb_z_is_complex_) then
call z%mlt(alpha,x%v,y%v,beta,info)
else
conjgx_=.false.
if (present(conjgx)) conjgx_ = (psb_toupper(conjgx)=='C')
conjgy_=.false.
if (present(conjgy)) conjgy_ = (psb_toupper(conjgy)=='C')
if (conjgx_) x%v=conjg(x%v)
if (conjgy_) y%v=conjg(y%v)
call z%mlt(alpha,x%v,y%v,beta,info)
if (conjgx_) x%v=conjg(x%v)
if (conjgy_) y%v=conjg(y%v)
end if
if (present(yconj)) then
if (psb_toupper(yconj)=='C') y%v=conjg(y%v)
end if
call z%mlt(alpha,x%v,y%v,beta,info)
if (present(xconj)) then
if (psb_toupper(xconj)=='C') x%v=conjg(x%v)
end if
if (present(yconj)) then
if (psb_toupper(yconj)=='C') y%v=conjg(y%v)
end if
end subroutine z_base_mlt_v_2
subroutine z_base_mlt_av(alpha,x,y,beta,z,info,xconj,yconj)
subroutine z_base_mlt_av(alpha,x,y,beta,z,info)
use psi_serial_mod
implicit none
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(in) :: x(:)
class(psb_z_base_vect_type), intent(inout) :: y
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
character(len=1), intent(in), optional :: xconj, yconj
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(in) :: x(:)
class(psb_z_base_vect_type), intent(inout) :: y
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
integer :: i, n
info = 0
@@ -411,20 +384,19 @@ contains
end subroutine z_base_mlt_av
subroutine z_base_mlt_va(alpha,x,y,beta,z,info,xconj,yconj)
subroutine z_base_mlt_va(alpha,x,y,beta,z,info)
use psi_serial_mod
implicit none
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(in) :: y(:)
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
character(len=1), intent(in), optional :: xconj, yconj
complex(psb_dpk_), intent(in) :: alpha,beta
complex(psb_dpk_), intent(in) :: y(:)
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: z
integer, intent(out) :: info
integer :: i, n
info = 0
call z%mlt(alpha,y,x,beta,info,xconj=yconj,yconj=xconj)
call z%mlt(alpha,y,x,beta,info)
end subroutine z_base_mlt_va
@@ -570,7 +542,7 @@ contains
class(psb_z_base_vect_type), intent(inout) :: x
integer, intent(in) :: n, dupl
integer, intent(in) :: irl(:)
complex(psb_dpk_), intent(in) :: val(:)
complex(psb_dpk_), intent(in) :: val(:)
integer, intent(out) :: info
integer :: i
base/modules/psb_z_mat_mod.f90
+4 -4
View File
@@ -699,7 +699,7 @@ module psb_z_mat_mod
import :: psb_zspmat_type, psb_dpk_
class(psb_zspmat_type), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
integer, intent(out) :: info
integer, intent(out) :: info
end subroutine psb_z_aclsum
end interface
@@ -708,7 +708,7 @@ module psb_z_mat_mod
subroutine psb_z_get_diag(a,d,info)
import :: psb_zspmat_type, psb_dpk_
class(psb_zspmat_type), intent(in) :: a
complex(psb_dpk_), intent(out) :: d(:)
complex(psb_dpk_), intent(out) :: d(:)
integer, intent(out) :: info
end subroutine psb_z_get_diag
end interface
@@ -717,13 +717,13 @@ module psb_z_mat_mod
subroutine psb_z_scal(d,a,info)
import :: psb_zspmat_type, psb_dpk_
class(psb_zspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: d(:)
complex(psb_dpk_), intent(in) :: d(:)
integer, intent(out) :: info
end subroutine psb_z_scal
subroutine psb_z_scals(d,a,info)
import :: psb_zspmat_type, psb_dpk_
class(psb_zspmat_type), intent(inout) :: a
complex(psb_dpk_), intent(in) :: d
complex(psb_dpk_), intent(in) :: d
integer, intent(out) :: info
end subroutine psb_z_scals
end interface
base/serial/impl/psb_c_base_mat_impl.f90
+30 -27
View File
@@ -295,6 +295,11 @@ end subroutine psb_c_base_csgetrow
!
! Here we have the base implementation of getblk and clip:
! this is just based on the getrow.
! If performance is critical it can be overridden.
!
subroutine psb_c_base_csgetblk(imin,imax,a,b,info,&
& jmin,jmax,iren,append,rscale,cscale)
! Output is always in COO format
@@ -474,7 +479,7 @@ subroutine psb_c_base_transp_2mat(a,b)
implicit none
class(psb_c_base_sparse_mat), intent(in) :: a
class(psb_base_sparse_mat), intent(out) :: b
class(psb_base_sparse_mat), intent(out) :: b
type(psb_c_coo_sparse_mat) :: tmp
integer err_act, info
@@ -512,7 +517,7 @@ subroutine psb_c_base_transc_2mat(a,b)
implicit none
class(psb_c_base_sparse_mat), intent(in) :: a
class(psb_base_sparse_mat), intent(out) :: b
class(psb_base_sparse_mat), intent(out) :: b
type(psb_c_coo_sparse_mat) :: tmp
integer err_act, info
@@ -542,7 +547,6 @@ subroutine psb_c_base_transc_2mat(a,b)
end if
return
end subroutine psb_c_base_transc_2mat
subroutine psb_c_base_transp_1mat(a)
@@ -584,6 +588,7 @@ subroutine psb_c_base_transc_1mat(a)
implicit none
class(psb_c_base_sparse_mat), intent(inout) :: a
type(psb_c_coo_sparse_mat) :: tmp
integer :: err_act, info
character(len=*), parameter :: name='c_base_transc'
@@ -1087,6 +1092,7 @@ subroutine psb_c_base_scal(d,a,info)
end subroutine psb_c_base_scal
function psb_c_base_maxval(a) result(res)
use psb_error_mod
use psb_const_mod
@@ -1110,13 +1116,12 @@ function psb_c_base_maxval(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -sone
res = szero
return
end function psb_c_base_maxval
function psb_c_base_csnmi(a) result(res)
use psb_error_mod
use psb_const_mod
@@ -1140,7 +1145,7 @@ function psb_c_base_csnmi(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -sone
res = szero
return
@@ -1169,7 +1174,7 @@ function psb_c_base_csnm1(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -sone
res = szero
return
@@ -1180,7 +1185,7 @@ subroutine psb_c_base_rowsum(d,a)
use psb_const_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_base_rowsum
class(psb_c_base_sparse_mat), intent(in) :: a
complex(psb_spk_), intent(out) :: d(:)
complex(psb_spk_), intent(out) :: d(:)
Integer :: err_act, info
character(len=20) :: name='rowsum'
@@ -1232,7 +1237,7 @@ subroutine psb_c_base_colsum(d,a)
use psb_const_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_base_colsum
class(psb_c_base_sparse_mat), intent(in) :: a
complex(psb_spk_), intent(out) :: d(:)
complex(psb_spk_), intent(out) :: d(:)
Integer :: err_act, info
character(len=20) :: name='colsum'
@@ -1279,6 +1284,7 @@ subroutine psb_c_base_aclsum(d,a)
end subroutine psb_c_base_aclsum
subroutine psb_c_base_get_diag(a,d,info)
use psb_error_mod
use psb_const_mod
@@ -1309,12 +1315,11 @@ subroutine psb_c_base_get_diag(a,d,info)
end subroutine psb_c_base_get_diag
! == ==================================
!
!
!
! Computational routines for C_VECT
! Computational routines for c_VECT
! variables. If the actual data type is
! a "normal" one, these are sufficient.
!
@@ -1330,12 +1335,12 @@ subroutine psb_c_base_vect_mv(alpha,a,x,beta,y,info,trans)
use psb_const_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_base_vect_mv
implicit none
class(psb_c_base_sparse_mat), intent(in) :: a
complex(psb_spk_), intent(in) :: alpha, beta
class(psb_c_base_sparse_mat), intent(in) :: a
complex(psb_spk_), intent(in) :: alpha, beta
class(psb_c_base_vect_type), intent(inout) :: x
class(psb_c_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
character, optional, intent(in) :: trans
integer, intent(out) :: info
character, optional, intent(in) :: trans
! For the time being we just throw everything back
! onto the normal routines.
@@ -1351,18 +1356,18 @@ subroutine psb_c_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
use psb_error_mod
use psb_string_mod
implicit none
class(psb_c_base_sparse_mat), intent(in) :: a
complex(psb_spk_), intent(in) :: alpha, beta
class(psb_c_base_sparse_mat), intent(in) :: a
complex(psb_spk_), intent(in) :: alpha, beta
class(psb_c_base_vect_type), intent(inout) :: x,y
integer, intent(out) :: info
character, optional, intent(in) :: trans, scale
integer, intent(out) :: info
character, optional, intent(in) :: trans, scale
class(psb_c_base_vect_type), intent(inout),optional :: d
complex(psb_spk_), allocatable :: tmp(:)
class(psb_c_base_vect_type), allocatable :: tmpv
Integer :: err_act, nar,nac,nc, i
character(len=1) :: scale_
character(len=20) :: name='s_cssm'
character(len=20) :: name='c_cssm'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
@@ -1490,14 +1495,14 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
use psb_string_mod
use psb_c_base_vect_mod
implicit none
class(psb_c_base_sparse_mat), intent(in) :: a
complex(psb_spk_), intent(in) :: alpha, beta
class(psb_c_base_sparse_mat), intent(in) :: a
complex(psb_spk_), intent(in) :: alpha, beta
class(psb_c_base_vect_type), intent(inout) :: x, y
integer, intent(out) :: info
character, optional, intent(in) :: trans
integer, intent(out) :: info
character, optional, intent(in) :: trans
Integer :: err_act
character(len=20) :: name='s_base_inner_vect_sv'
character(len=20) :: name='c_base_inner_vect_sv'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
@@ -1529,5 +1534,3 @@ subroutine psb_c_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
return
end subroutine psb_c_base_inner_vect_sv
base/serial/impl/psb_c_coo_impl.f90
+95 -72
View File
@@ -215,7 +215,7 @@ subroutine psb_c_coo_reinit(a,clear)
! do nothing
return
else if (a%is_asb()) then
if (clear_) a%val(:) = zzero
if (clear_) a%val(:) = czero
call a%set_upd()
else
info = psb_err_invalid_mat_state_
@@ -351,6 +351,7 @@ subroutine psb_c_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc)
character(len=20) :: name='c_coo_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -378,7 +379,11 @@ subroutine psb_c_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
@@ -519,10 +524,10 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans)
nc = min(size(x,2) , size(y,2))
nnz = a%get_nzeros()
if (alpha == zzero) then
if (beta == zzero) then
if (alpha == czero) then
if (beta == czero) then
do i = 1, m
y(i,1:nc) = zzero
y(i,1:nc) = czero
enddo
else
do i = 1, m
@@ -532,7 +537,7 @@ subroutine psb_c_coo_cssm(alpha,a,x,beta,y,info,trans)
return
end if
if (beta == zzero) then
if (beta == czero) then
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),y,size(y,1),info)
@@ -582,8 +587,8 @@ contains
implicit none
logical, intent(in) :: tra,ctra,lower,unit,sorted
integer, intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*)
complex(psb_spk_), intent(in) :: val(*), x(ldx,*)
complex(psb_spk_), intent(out) :: y(ldy,*)
complex(psb_spk_), intent(in) :: val(*), x(ldx,*)
complex(psb_spk_), intent(out) :: y(ldy,*)
integer, intent(out) :: info
integer :: i,j,k,m, ir, jc
@@ -604,13 +609,14 @@ contains
nnz = nz
if ((.not.tra).and.(.not.ctra)) then
if (lower) then
if (unit) then
j = 1
do i=1, nr
acc(1:nc) = zzero
acc(1:nc) = czero
do
if (j > nnz) exit
if (ia(j) > i) exit
@@ -622,7 +628,7 @@ contains
else if (.not.unit) then
j = 1
do i=1, nr
acc(1:nc) = zzero
acc(1:nc) = czero
do
if (j > nnz) exit
if (ia(j) > i) exit
@@ -641,7 +647,7 @@ contains
if (unit) then
j = nnz
do i=nr, 1, -1
acc(1:nc) = zzero
acc(1:nc) = czero
do
if (j < 1) exit
if (ia(j) < i) exit
@@ -655,7 +661,7 @@ contains
j = nnz
do i=nr, 1, -1
acc(1:nc) = zzero
acc(1:nc) = czero
do
if (j < 1) exit
if (ia(j) < i) exit
@@ -764,7 +770,7 @@ contains
j = nnz
do i=nr, 1, -1
if (ja(j) == i) then
y(i,1:nc) = y(i,1:nc) /conjg(val(j))
y(i,1:nc) = y(i,1:nc) / conjg(val(j))
j = j - 1
end if
acc(1:nc) = y(i,1:nc)
@@ -794,7 +800,7 @@ contains
j = 1
do i=1, nr
if (ja(j) == i) then
y(i,1:nc) = y(i,1:nc) /conjg(val(j))
y(i,1:nc) = y(i,1:nc) / conjg(val(j))
j = j + 1
end if
acc(1:nc) = y(i,1:nc)
@@ -809,6 +815,7 @@ contains
end if
end if
end if
end if
end subroutine inner_coosm
@@ -851,6 +858,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
@@ -871,10 +879,10 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans)
end if
if (alpha == zzero) then
if (beta == zzero) then
if (alpha == czero) then
if (beta == czero) then
do i = 1, m
y(i) = zzero
y(i) = czero
enddo
else
do i = 1, m
@@ -884,7 +892,7 @@ subroutine psb_c_coo_cssv(alpha,a,x,beta,y,info,trans)
return
end if
if (beta == zzero) then
if (beta == czero) then
call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,&
& x,y,info)
@@ -934,8 +942,8 @@ contains
implicit none
logical, intent(in) :: tra,ctra,lower,unit,sorted
integer, intent(in) :: nr,nz,ia(*),ja(*)
complex(psb_spk_), intent(in) :: val(*), x(*)
complex(psb_spk_), intent(out) :: y(*)
complex(psb_spk_), intent(in) :: val(*), x(*)
complex(psb_spk_), intent(out) :: y(*)
integer, intent(out) :: info
integer :: i,j,k,m, ir, jc, nnz
@@ -955,7 +963,7 @@ contains
if (unit) then
j = 1
do i=1, nr
acc = zzero
acc = czero
do
if (j > nnz) exit
if (ia(j) > i) exit
@@ -967,7 +975,7 @@ contains
else if (.not.unit) then
j = 1
do i=1, nr
acc = zzero
acc = czero
do
if (j > nnz) exit
if (ia(j) > i) exit
@@ -986,7 +994,7 @@ contains
if (unit) then
j = nnz
do i=nr, 1, -1
acc = zzero
acc = czero
do
if (j < 1) exit
if (ia(j) < i) exit
@@ -1000,7 +1008,7 @@ contains
j = nnz
do i=nr, 1, -1
acc = zzero
acc = czero
do
if (j < 1) exit
if (ia(j) < i) exit
@@ -1198,11 +1206,11 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
trans_ = 'N'
end if
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
@@ -1222,10 +1230,10 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
end if
nnz = a%get_nzeros()
if (alpha == zzero) then
if (beta == zzero) then
if (alpha == czero) then
if (beta == czero) then
do i = 1, m
y(i) = zzero
y(i) = czero
enddo
else
do i = 1, m
@@ -1235,12 +1243,12 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
return
else
if (a%is_triangle().and.a%is_unit()) then
if (beta == zzero) then
if (beta == czero) then
do i = 1, min(m,n)
y(i) = alpha*x(i)
enddo
do i = min(m,n)+1, m
y(i) = zzero
y(i) = czero
enddo
else
do i = 1, min(m,n)
@@ -1251,9 +1259,9 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
enddo
endif
else
if (beta == zzero) then
if (beta == czero) then
do i = 1, m
y(i) = zzero
y(i) = czero
enddo
else
do i = 1, m
@@ -1270,7 +1278,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
j = i
if (nnz > 0) then
ir = a%ia(1)
acc = zzero
acc = czero
do
if (i>nnz) then
y(ir) = y(ir) + alpha * acc
@@ -1279,7 +1287,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
if (a%ia(i) /= ir) then
y(ir) = y(ir) + alpha * acc
ir = a%ia(i)
acc = zzero
acc = czero
endif
acc = acc + a%val(i) * x(a%ja(i))
i = i + 1
@@ -1288,7 +1296,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
else if (tra) then
if (alpha == zone) then
if (alpha == cone) then
i = 1
do i=1,nnz
ir = a%ja(i)
@@ -1296,7 +1304,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
y(ir) = y(ir) + a%val(i)*x(jc)
enddo
else if (alpha == -zone) then
else if (alpha == -cone) then
do i=1,nnz
ir = a%ja(i)
@@ -1316,7 +1324,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
else if (ctra) then
if (alpha == zone) then
if (alpha == cone) then
i = 1
do i=1,nnz
ir = a%ja(i)
@@ -1324,7 +1332,7 @@ subroutine psb_c_coo_csmv(alpha,a,x,beta,y,info,trans)
y(ir) = y(ir) + conjg(a%val(i))*x(jc)
enddo
else if (alpha == -zone) then
else if (alpha == -cone) then
do i=1,nnz
ir = a%ja(i)
@@ -1430,10 +1438,10 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
if (alpha == zzero) then
if (beta == zzero) then
if (alpha == czero) then
if (beta == czero) then
do i = 1, m
y(i,1:nc) = zzero
y(i,1:nc) = czero
enddo
else
do i = 1, m
@@ -1443,12 +1451,12 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
return
else
if (a%is_triangle().and.a%is_unit()) then
if (beta == zzero) then
if (beta == czero) then
do i = 1, min(m,n)
y(i,1:nc) = alpha*x(i,1:nc)
enddo
do i = min(m,n)+1, m
y(i,1:nc) = zzero
y(i,1:nc) = czero
enddo
else
do i = 1, min(m,n)
@@ -1459,9 +1467,9 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
enddo
endif
else
if (beta == zzero) then
if (beta == czero) then
do i = 1, m
y(i,1:nc) = zzero
y(i,1:nc) = czero
enddo
else
do i = 1, m
@@ -1473,12 +1481,12 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
if ((.not.tra).and.(.not.ctra)) then
if (.not.tra) then
i = 1
j = i
if (nnz > 0) then
ir = a%ia(1)
acc = zzero
acc = czero
do
if (i>nnz) then
y(ir,1:nc) = y(ir,1:nc) + alpha * acc
@@ -1487,7 +1495,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
if (a%ia(i) /= ir) then
y(ir,1:nc) = y(ir,1:nc) + alpha * acc
ir = a%ia(i)
acc = zzero
acc = czero
endif
acc = acc + a%val(i) * x(a%ja(i),1:nc)
i = i + 1
@@ -1495,7 +1503,8 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
else if (tra) then
if (alpha == zone) then
if (alpha == cone) then
i = 1
do i=1,nnz
ir = a%ja(i)
@@ -1503,7 +1512,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
y(ir,1:nc) = y(ir,1:nc) + a%val(i)*x(jc,1:nc)
enddo
else if (alpha == -zone) then
else if (alpha == -cone) then
do i=1,nnz
ir = a%ja(i)
@@ -1523,7 +1532,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
else if (ctra) then
if (alpha == zone) then
if (alpha == cone) then
i = 1
do i=1,nnz
ir = a%ja(i)
@@ -1531,7 +1540,7 @@ subroutine psb_c_coo_csmm(alpha,a,x,beta,y,info,trans)
y(ir,1:nc) = y(ir,1:nc) + conjg(a%val(i))*x(jc,1:nc)
enddo
else if (alpha == -zone) then
else if (alpha == -cone) then
do i=1,nnz
ir = a%ja(i)
@@ -1592,30 +1601,45 @@ function psb_c_coo_csnmi(a) result(res)
class(psb_c_coo_sparse_mat), intent(in) :: a
real(psb_spk_) :: res
integer :: i,j,k,m,n, nnz, ir, jc, nc
integer :: i,j,k,m,n, nnz, ir, jc, nc, info
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: vt(:)
logical :: tra
Integer :: err_act
character(len=20) :: name='c_base_csnmi'
character(len=20) :: name='c_coo_csnmi'
logical, parameter :: debug=.false.
res = szero
res = szero
nnz = a%get_nzeros()
i = 1
j = i
do while (i<=nnz)
do while ((a%ia(j) == a%ia(i)).and. (j <= nnz))
j = j+1
enddo
acc = szero
do k=i, j-1
acc = acc + abs(a%val(k))
if (a%is_sorted()) then
i = 1
j = i
res = szero
do while (i<=nnz)
do while ((a%ia(j) == a%ia(i)).and. (j <= nnz))
j = j+1
enddo
acc = szero
do k=i, j-1
acc = acc + abs(a%val(k))
end do
res = max(res,acc)
i = j
end do
res = max(res,acc)
i = j
end do
else
m = a%get_nrows()
allocate(vt(m),stat=info)
if (info /= 0) return
vt(:) = szero
do j=1, nnz
i = a%ia(j)
vt(i) = vt(i) + abs(a%val(j))
end do
res = maxval(vt(1:m))
deallocate(vt,stat=info)
end if
end function psb_c_coo_csnmi
@@ -1633,11 +1657,11 @@ function psb_c_coo_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
Integer :: err_act
character(len=20) :: name='d_coo_csnm1'
character(len=20) :: name='c_coo_csnm1'
logical, parameter :: debug=.false.
res = szero
res = szero
nnz = a%get_nzeros()
n = a%get_ncols()
allocate(vt(n),stat=info)
@@ -1708,7 +1732,7 @@ subroutine psb_c_coo_arwsum(d,a)
use psb_const_mod
use psb_c_base_mat_mod, psb_protect_name => psb_c_coo_arwsum
class(psb_c_coo_sparse_mat), intent(in) :: a
real(psb_spk_), intent(out) :: d(:)
real(psb_spk_), intent(out) :: d(:)
integer :: i,j,k,m,n, nnz, ir, jc, nc
real(psb_spk_) :: acc
@@ -2820,7 +2844,6 @@ subroutine psb_c_cp_coo_to_coo(a,b,info)
info = psb_success_
call b%psb_c_base_sparse_mat%cp_from(a%psb_c_base_sparse_mat)
nz = a%get_nzeros()
call b%set_nzeros(nz)
call b%reallocate(nz)
base/serial/impl/psb_c_csc_impl.f90
+62 -420
View File
@@ -1,3 +1,4 @@
! == ===================================
!
!
@@ -25,7 +26,7 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc
complex(psb_spk_) :: acc
logical :: tra, ctra
logical :: tra
Integer :: err_act
character(len=20) :: name='c_csc_csmv'
logical, parameter :: debug=.false.
@@ -46,11 +47,9 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans)
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra.or.ctra) then
if (tra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -222,144 +221,7 @@ subroutine psb_c_csc_csmv(alpha,a,x,beta,y,info,trans)
end if
else if (ctra) then
if (beta == czero) then
if (alpha == cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = acc
end do
else if (alpha == -cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = -acc
end do
else
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = alpha*acc
end do
end if
else if (beta == cone) then
if (alpha == cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = y(i) + acc
end do
else if (alpha == -cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = y(i) -acc
end do
else
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = y(i) + alpha*acc
end do
end if
else if (beta == -cone) then
if (alpha == cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = -y(i) + acc
end do
else if (alpha == -cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = -y(i) -acc
end do
else
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = -y(i) + alpha*acc
end do
end if
else
if (alpha == cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = beta*y(i) + acc
end do
else if (alpha == -cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = beta*y(i) - acc
end do
else
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = beta*y(i) + alpha*acc
end do
end if
end if
else if (.not.(tra.or.ctra)) then
else if (.not.tra) then
if (beta == czero) then
do i=1, m
@@ -441,7 +303,7 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc, nc
complex(psb_spk_), allocatable :: acc(:)
logical :: tra, ctra
logical :: tra
Integer :: err_act
character(len=20) :: name='c_csc_csmm'
logical, parameter :: debug=.false.
@@ -455,16 +317,14 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans)
trans_ = 'N'
end if
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
if (.not.a%is_asb()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra.or.ctra) then
if (tra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -644,144 +504,7 @@ subroutine psb_c_csc_csmm(alpha,a,x,beta,y,info,trans)
end if
else if (ctra) then
if (beta == czero) then
if (alpha == cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = acc
end do
else if (alpha == -cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = -acc
end do
else
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = alpha*acc
end do
end if
else if (beta == cone) then
if (alpha == cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = y(i,:) + acc
end do
else if (alpha == -cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = y(i,:) -acc
end do
else
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = y(i,:) + alpha*acc
end do
end if
else if (beta == -cone) then
if (alpha == cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = -y(i,:) + acc
end do
else if (alpha == -cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = -y(i,:) -acc
end do
else
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = -y(i,:) + alpha*acc
end do
end if
else
if (alpha == cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = beta*y(i,:) + acc
end do
else if (alpha == -cone) then
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = beta*y(i,:) - acc
end do
else
do i=1,m
acc = czero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = beta*y(i,:) + alpha*acc
end do
end if
end if
else if (.not.(tra.or.ctra)) then
else if (.not.tra) then
if (beta == czero) then
do i=1, m
@@ -865,7 +588,7 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m, nnz, ir, jc
complex(psb_spk_) :: acc
complex(psb_spk_), allocatable :: tmp(:)
logical :: tra, ctra
logical :: tra
Integer :: err_act
character(len=20) :: name='c_csc_cssv'
logical, parameter :: debug=.false.
@@ -883,9 +606,7 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
if (.not. (a%is_triangle())) then
@@ -922,7 +643,7 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans)
end if
if (beta == czero) then
call inner_cscsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),&
call inner_cscsv(tra,a%is_lower(),a%is_unit(),a%get_nrows(),&
& a%icp,a%ia,a%val,x,y)
if (alpha == cone) then
! do nothing
@@ -941,7 +662,7 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans)
return
end if
tmp(1:m) = x(1:m)
call inner_cscsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),&
call inner_cscsv(tra,a%is_lower(),a%is_unit(),a%get_nrows(),&
& a%icp,a%ia,a%val,tmp,y)
do i = 1, m
y(i) = alpha*tmp(i) + beta*y(i)
@@ -962,9 +683,9 @@ subroutine psb_c_csc_cssv(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_cscsv(tra,ctra,lower,unit,n,icp,ia,val,x,y)
subroutine inner_cscsv(tra,lower,unit,n,icp,ia,val,x,y)
implicit none
logical, intent(in) :: tra,ctra,lower,unit
logical, intent(in) :: tra,lower,unit
integer, intent(in) :: icp(*), ia(*),n
complex(psb_spk_), intent(in) :: val(*)
complex(psb_spk_), intent(in) :: x(*)
@@ -1013,53 +734,10 @@ contains
y(i) = (x(i) - acc)/val(icp(i+1)-1)
end do
end if
end if
else if (ctra) then
if (lower) then
if (unit) then
do i=n, 1, -1
acc = czero
do j=icp(i), icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j))
end do
y(i) = x(i) - acc
end do
else if (.not.unit) then
do i=n, 1, -1
acc = czero
do j=icp(i)+1, icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j))
end do
y(i) = (x(i) - acc)/conjg(val(icp(i)))
end do
end if
else if (.not.lower) then
if (unit) then
do i=1, n
acc = czero
do j=icp(i), icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j))
end do
y(i) = x(i) - acc
end do
else if (.not.unit) then
do i=1, n
acc = czero
do j=icp(i), icp(i+1)-2
acc = acc + conjg(val(j))*y(ia(j))
end do
y(i) = (x(i) - acc)/conjg(val(icp(i+1)-1))
end do
end if
end if
else if (.not.(tra.or.ctra)) then
else if (.not.tra) then
do i=1, n
y(i) = x(i)
@@ -1130,7 +808,7 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m,n, nnz, ir, jc, nc
complex(psb_spk_) :: acc
complex(psb_spk_), allocatable :: tmp(:,:)
logical :: tra, ctra
logical :: tra
Integer :: err_act
character(len=20) :: name='c_base_csmm'
logical, parameter :: debug=.false.
@@ -1150,11 +828,8 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
nc = min(size(x,2) , size(y,2))
if (size(x,1)<m) then
info = 36
@@ -1168,6 +843,7 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
goto 9999
end if
nc = min(size(x,2) , size(y,2))
if (.not. (a%is_triangle())) then
info = psb_err_invalid_mat_state_
@@ -1190,7 +866,7 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
end if
if (beta == czero) then
call inner_cscsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,x,size(x,1),y,size(y,1),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
@@ -1204,7 +880,7 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
end if
tmp(1:m,:) = x(1:m,1:nc)
call inner_cscsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,tmp,size(tmp,1),y,size(y,1),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
@@ -1233,10 +909,10 @@ subroutine psb_c_csc_cssm(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_cscsm(tra,ctra,lower,unit,nr,nc,&
subroutine inner_cscsm(tra,lower,unit,nr,nc,&
& icp,ia,val,x,ldx,y,ldy,info)
implicit none
logical, intent(in) :: tra,ctra,lower,unit
logical, intent(in) :: tra,lower,unit
integer, intent(in) :: nr,nc,ldx,ldy,icp(*),ia(*)
complex(psb_spk_), intent(in) :: val(*), x(ldx,*)
complex(psb_spk_), intent(out) :: y(ldy,*)
@@ -1255,25 +931,6 @@ contains
if (tra) then
if (lower) then
if (unit) then
do i=1, nr
acc = czero
do j=icp(i), icp(i+1)-1
acc = acc + val(j)*y(ia(j),1:nc)
end do
y(i,1:nc) = x(i,1:nc) - acc
end do
else if (.not.unit) then
do i=1, nr
acc = czero
do j=icp(i), icp(i+1)-2
acc = acc + val(j)*y(ia(j),1:nc)
end do
y(i,1:nc) = (x(i,1:nc) - acc)/val(icp(i+1)-1)
end do
end if
else if (.not.lower) then
if (unit) then
do i=nr, 1, -1
acc = czero
@@ -1292,16 +949,13 @@ contains
end do
end if
end if
else if (.not.lower) then
else if (ctra) then
if (lower) then
if (unit) then
do i=1, nr
acc = czero
do j=icp(i), icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j),1:nc)
acc = acc + val(j)*y(ia(j),1:nc)
end do
y(i,1:nc) = x(i,1:nc) - acc
end do
@@ -1309,40 +963,43 @@ contains
do i=1, nr
acc = czero
do j=icp(i), icp(i+1)-2
acc = acc + conjg(val(j))*y(ia(j),1:nc)
acc = acc + val(j)*y(ia(j),1:nc)
end do
y(i,1:nc) = (x(i,1:nc) - acc)/conjg(val(icp(i+1)-1))
end do
end if
else if (.not.lower) then
if (unit) then
do i=nr, 1, -1
acc = czero
do j=icp(i), icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j),1:nc)
end do
y(i,1:nc) = x(i,1:nc) - acc
end do
else if (.not.unit) then
do i=nr, 1, -1
acc = czero
do j=icp(i)+1, icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j),1:nc)
end do
y(i,1:nc) = (x(i,1:nc) - acc)/conjg(val(icp(i)))
y(i,1:nc) = (x(i,1:nc) - acc)/val(icp(i+1)-1)
end do
end if
end if
else if (.not.(tra.or.ctra)) then
else if (.not.tra) then
do i=1, nr
y(i,1:nc) = x(i,1:nc)
end do
if (lower) then
if (lower) then
if (unit) then
do i=1, nr
acc = y(i,1:nc)
do j=icp(i), icp(i+1)-1
jc = ia(j)
y(jc,1:nc) = y(jc,1:nc) - val(j)*acc
end do
end do
else if (.not.unit) then
do i=1, nr
y(i,1:nc) = y(i,1:nc)/val(icp(i))
acc = y(i,1:nc)
do j=icp(i)+1, icp(i+1)-1
jc = ia(j)
y(jc,1:nc) = y(jc,1:nc) - val(j)*acc
end do
end do
end if
else if (.not.lower) then
if (unit) then
do i=nr, 1, -1
acc = y(i,1:nc)
@@ -1361,26 +1018,6 @@ contains
end do
end do
end if
else if (.not.lower) then
if (unit) then
do i=1, nr
acc = y(i,1:nc)
do j=icp(i), icp(i+1)-1
jc = ia(j)
y(jc,1:nc) = y(jc,1:nc) - val(j)*acc
end do
end do
else if (.not.unit) then
do i=1, nr
y(i,1:nc) = y(i,1:nc)/val(icp(i))
acc = y(i,1:nc)
do j=icp(i)+1, icp(i+1)-1
jc = ia(j)
y(jc,1:nc) = y(jc,1:nc) - val(j)*acc
end do
end do
end if
end if
end if
@@ -1458,7 +1095,7 @@ function psb_c_csc_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
Integer :: err_act
character(len=20) :: name='d_csc_csnm1'
character(len=20) :: name='c_csc_csnm1'
logical, parameter :: debug=.false.
@@ -1716,11 +1353,10 @@ subroutine psb_c_csc_get_diag(a,d,info)
endif
enddo
end do
end if
endif
do i=mnm+1,size(d)
d(i) = czero
end do
call psb_erractionrestore(err_act)
return
@@ -2630,8 +2266,8 @@ subroutine psb_c_mv_csc_from_coo(a,b,info)
logical :: rwshr_
Integer :: nza, nr, i,j,irw, err_act, nc, icl
Integer, Parameter :: maxtry=8
integer :: debug_level, debug_unit
character(len=20) :: name='csc_from_coo'
integer :: debug_level, debug_unit
character(len=20) :: name
info = psb_success_
debug_unit = psb_get_debug_unit()
@@ -2894,6 +2530,7 @@ subroutine psb_c_csc_mold(a,b,info)
end subroutine psb_c_csc_mold
subroutine psb_c_csc_reallocate_nz(nz,a)
use psb_error_mod
use psb_realloc_mod
@@ -3150,6 +2787,7 @@ subroutine psb_c_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc)
character(len=20) :: name='c_csc_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -3177,7 +2815,11 @@ subroutine psb_c_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nc
base/serial/impl/psb_c_csr_impl.f90
+11 -7
View File
@@ -1248,7 +1248,7 @@ function psb_c_csr_maxval(a) result(res)
logical, parameter :: debug=.false.
res = szero
res = szero
nnz = a%get_nzeros()
if (allocated(a%val)) then
nnz = min(nnz,size(a%val))
@@ -1271,10 +1271,10 @@ function psb_c_csr_csnmi(a) result(res)
logical, parameter :: debug=.false.
res = szero
res = szero
do i = 1, a%get_nrows()
acc = szero
acc = dzero
do j=a%irp(i),a%irp(i+1)-1
acc = acc + abs(a%val(j))
end do
@@ -1548,7 +1548,7 @@ subroutine psb_c_csr_get_diag(a,d,info)
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = cone
d(1:mnm) = cone
else
do i=1, mnm
d(i) = czero
@@ -2529,7 +2529,7 @@ subroutine psb_c_csr_reinit(a,clear)
! do nothing
return
else if (a%is_asb()) then
if (clear_) a%val(:) = dzero
if (clear_) a%val(:) = czero
call a%set_upd()
else
info = psb_err_invalid_mat_state_
@@ -2600,7 +2600,7 @@ subroutine psb_c_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc)
Integer :: err_act
character(len=20) :: name='c_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -2628,7 +2628,11 @@ subroutine psb_c_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nr
base/serial/impl/psb_c_mat_impl.F90
+9 -6
View File
@@ -1022,6 +1022,13 @@ subroutine psb_c_cscnv(a,b,info,type,mold,upd,dupl)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
call b%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call b%set_dupl(psb_dupl_def_)
end if
if (count( (/present(mold),present(type) /)) > 1) then
info = psb_err_many_optional_arg_
call psb_errpush(info,name,a_err='TYPE, MOLD')
@@ -1402,8 +1409,8 @@ subroutine psb_c_cp_from(a,b)
use psb_string_mod
use psb_c_mat_mod, psb_protect_name => psb_c_cp_from
implicit none
class(psb_cspmat_type), intent(out) :: a
class(psb_c_base_sparse_mat), intent(in) :: b
class(psb_cspmat_type), intent(out) :: a
class(psb_c_base_sparse_mat), intent(inout), allocatable :: b
Integer :: err_act, info
character(len=20) :: name='clone'
logical, parameter :: debug=.false.
@@ -1421,7 +1428,6 @@ subroutine psb_c_cp_from(a,b)
#else
call b%mold(a%a,info)
#endif
if (info /= psb_success_) info = psb_err_alloc_dealloc_
if (info == psb_success_) call a%a%cp_from_fmt(b, info)
if (info /= psb_success_) goto 9999
@@ -2067,7 +2073,6 @@ function psb_c_csnmi(a) result(res)
character(len=20) :: name='csnmi'
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_
@@ -2289,7 +2294,6 @@ subroutine psb_c_get_diag(a,d,info)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = psb_err_invalid_mat_state_
@@ -2328,7 +2332,6 @@ subroutine psb_c_scal(d,a,info)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = psb_err_invalid_mat_state_
base/serial/impl/psb_d_base_mat_impl.f90
+37 -7
View File
@@ -295,6 +295,11 @@ end subroutine psb_d_base_csgetrow
!
! Here we have the base implementation of getblk and clip:
! this is just based on the getrow.
! If performance is critical it can be overridden.
!
subroutine psb_d_base_csgetblk(imin,imax,a,b,info,&
& jmin,jmax,iren,append,rscale,cscale)
! Output is always in COO format
@@ -474,7 +479,7 @@ subroutine psb_d_base_transp_2mat(a,b)
implicit none
class(psb_d_base_sparse_mat), intent(in) :: a
class(psb_base_sparse_mat), intent(out) :: b
class(psb_base_sparse_mat), intent(out) :: b
type(psb_d_coo_sparse_mat) :: tmp
integer err_act, info
@@ -512,7 +517,8 @@ subroutine psb_d_base_transc_2mat(a,b)
implicit none
class(psb_d_base_sparse_mat), intent(in) :: a
class(psb_base_sparse_mat), intent(out) :: b
class(psb_base_sparse_mat), intent(out) :: b
type(psb_d_coo_sparse_mat) :: tmp
integer err_act, info
character(len=*), parameter :: name='d_base_transc'
@@ -583,7 +589,31 @@ subroutine psb_d_base_transc_1mat(a)
class(psb_d_base_sparse_mat), intent(inout) :: a
call a%transp()
type(psb_d_coo_sparse_mat) :: tmp
integer :: err_act, info
character(len=*), parameter :: name='d_base_transc'
call psb_erractionsave(err_act)
info = psb_success_
call a%mv_to_coo(tmp,info)
if (info == psb_success_) call tmp%transc()
if (info == psb_success_) call a%mv_from_coo(tmp,info)
if (info /= psb_success_) then
info = psb_err_missing_override_method_
call psb_errpush(info,name,a_err=a%get_fmt())
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_d_base_transc_1mat
@@ -1086,7 +1116,7 @@ function psb_d_base_maxval(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -done
res = dzero
return
@@ -1115,7 +1145,7 @@ function psb_d_base_csnmi(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -done
res = dzero
return
@@ -1144,7 +1174,7 @@ function psb_d_base_csnm1(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -done
res = dzero
return
@@ -1289,7 +1319,7 @@ end subroutine psb_d_base_get_diag
!
!
!
! Computational routines for D_VECT
! Computational routines for d_VECT
! variables. If the actual data type is
! a "normal" one, these are sufficient.
!
base/serial/impl/psb_d_coo_impl.f90
+233 -24
View File
@@ -351,6 +351,7 @@ subroutine psb_d_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc)
character(len=20) :: name='d_coo_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -378,7 +379,11 @@ subroutine psb_d_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
@@ -476,7 +481,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m,n, nnz, ir, jc, nc
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='d_base_csmm'
logical, parameter :: debug=.false.
@@ -502,7 +507,8 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
else
trans_ = 'N'
end if
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
@@ -532,7 +538,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
end if
if (beta == dzero) then
call inner_coosm(tra,a%is_lower(),a%is_unit(),a%is_sorted(),&
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),y,size(y,1),info)
do i = 1, m
@@ -546,7 +552,7 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
goto 9999
end if
call inner_coosm(tra,a%is_lower(),a%is_unit(),a%is_sorted(),&
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),tmp,size(tmp,1),info)
do i = 1, m
@@ -576,10 +582,10 @@ subroutine psb_d_coo_cssm(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_coosm(tra,lower,unit,sorted,nr,nc,nz,&
subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,&
& ia,ja,val,x,ldx,y,ldy,info)
implicit none
logical, intent(in) :: tra,lower,unit,sorted
logical, intent(in) :: tra,ctra,lower,unit,sorted
integer, intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*)
real(psb_dpk_), intent(in) :: val(*), x(ldx,*)
real(psb_dpk_), intent(out) :: y(ldy,*)
@@ -603,7 +609,8 @@ contains
nnz = nz
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (lower) then
if (unit) then
@@ -739,6 +746,76 @@ contains
end if
end if
end if
else if (ctra) then
do i=1, nr
y(i,1:nc) = x(i,1:nc)
end do
if (lower) then
if (unit) then
j = nnz
do i=nr, 1, -1
acc(1:nc) = y(i,1:nc)
do
if (j < 1) exit
if (ia(j) < i) exit
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc)
j = j - 1
end do
end do
else if (.not.unit) then
j = nnz
do i=nr, 1, -1
if (ja(j) == i) then
y(i,1:nc) = y(i,1:nc) / (val(j))
j = j - 1
end if
acc(1:nc) = y(i,1:nc)
do
if (j < 1) exit
if (ia(j) < i) exit
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc)
j = j - 1
end do
end do
else if (.not.lower) then
if (unit) then
j = 1
do i=1, nr
acc(1:nc) = y(i,1:nc)
do
if (j > nnz) exit
if (ia(j) > i) exit
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc)
j = j + 1
end do
end do
else if (.not.unit) then
j = 1
do i=1, nr
if (ja(j) == i) then
y(i,1:nc) = y(i,1:nc) / (val(j))
j = j + 1
end if
acc(1:nc) = y(i,1:nc)
do
if (j > nnz) exit
if (ia(j) > i) exit
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc)
j = j + 1
end do
end do
end if
end if
end if
end if
end subroutine inner_coosm
@@ -762,7 +839,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m,n, nnz, ir, jc
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: tmp(:)
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='d_coo_cssv_impl'
logical, parameter :: debug=.false.
@@ -781,7 +858,9 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
@@ -814,7 +893,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans)
end if
if (beta == dzero) then
call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),&
call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,&
& x,y,info)
if (info /= psb_success_) then
@@ -832,7 +911,7 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
end if
call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),&
call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,&
& x,tmp,info)
if (info /= psb_success_) then
@@ -858,10 +937,10 @@ subroutine psb_d_coo_cssv(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_coosv(tra,lower,unit,sorted,nr,nz,&
subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,&
& ia,ja,val,x,y,info)
implicit none
logical, intent(in) :: tra,lower,unit,sorted
logical, intent(in) :: tra,ctra,lower,unit,sorted
integer, intent(in) :: nr,nz,ia(*),ja(*)
real(psb_dpk_), intent(in) :: val(*), x(*)
real(psb_dpk_), intent(out) :: y(*)
@@ -878,7 +957,7 @@ contains
nnz = nz
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (lower) then
if (unit) then
@@ -1014,6 +1093,75 @@ contains
end if
end if
end if
else if (ctra) then
do i=1, nr
y(i) = x(i)
end do
if (lower) then
if (unit) then
j = nnz
do i=nr, 1, -1
acc = y(i)
do
if (j < 1) exit
if (ia(j) < i) exit
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
j = j - 1
end do
end do
else if (.not.unit) then
j = nnz
do i=nr, 1, -1
if (ja(j) == i) then
y(i) = y(i) /(val(j))
j = j - 1
end if
acc = y(i)
do
if (j < 1) exit
if (ia(j) < i) exit
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
j = j - 1
end do
end do
else if (.not.lower) then
if (unit) then
j = 1
do i=1, nr
acc = y(i)
do
if (j > nnz) exit
if (ia(j) > i) exit
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
j = j + 1
end do
end do
else if (.not.unit) then
j = 1
do i=1, nr
if (ja(j) == i) then
y(i) = y(i) /(val(j))
j = j + 1
end if
acc = y(i)
do
if (j > nnz) exit
if (ia(j) > i) exit
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
j = j + 1
end do
end do
end if
end if
end if
end if
end subroutine inner_coosv
@@ -1037,7 +1185,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc
real(psb_dpk_) :: acc
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='d_coo_csmv_impl'
logical, parameter :: debug=.false.
@@ -1058,10 +1206,12 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans)
trans_ = 'N'
end if
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra) then
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -1123,7 +1273,7 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans)
end if
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
i = 1
j = i
if (nnz > 0) then
@@ -1172,6 +1322,34 @@ subroutine psb_d_coo_csmv(alpha,a,x,beta,y,info,trans)
end if !.....end testing on alpha
else if (ctra) then
if (alpha == done) then
i = 1
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir) = y(ir) + (a%val(i))*x(jc)
enddo
else if (alpha == -done) then
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir) = y(ir) - (a%val(i))*x(jc)
enddo
else
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir) = y(ir) + alpha*(a%val(i))*x(jc)
enddo
end if !.....end testing on alpha
endif
call psb_erractionrestore(err_act)
@@ -1204,7 +1382,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc, nc
real(psb_dpk_), allocatable :: acc(:)
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='d_coo_csmm_impl'
logical, parameter :: debug=.false.
@@ -1227,9 +1405,11 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra) then
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -1323,6 +1503,7 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
else if (tra) then
if (alpha == done) then
i = 1
do i=1,nnz
@@ -1349,6 +1530,34 @@ subroutine psb_d_coo_csmm(alpha,a,x,beta,y,info,trans)
end if !.....end testing on alpha
else if (ctra) then
if (alpha == done) then
i = 1
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir,1:nc) = y(ir,1:nc) + (a%val(i))*x(jc,1:nc)
enddo
else if (alpha == -done) then
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir,1:nc) = y(ir,1:nc) - (a%val(i))*x(jc,1:nc)
enddo
else
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir,1:nc) = y(ir,1:nc) + alpha*(a%val(i))*x(jc,1:nc)
enddo
end if !.....end testing on alpha
endif
call psb_erractionrestore(err_act)
@@ -1401,7 +1610,7 @@ function psb_d_coo_csnmi(a) result(res)
logical, parameter :: debug=.false.
res = -done
res = dzero
nnz = a%get_nzeros()
if (a%is_sorted()) then
i = 1
@@ -1452,7 +1661,7 @@ function psb_d_coo_csnm1(a) result(res)
logical, parameter :: debug=.false.
res = -done
res = dzero
nnz = a%get_nzeros()
n = a%get_ncols()
allocate(vt(n),stat=info)
base/serial/impl/psb_d_csc_impl.f90
+9 -4
View File
@@ -2266,8 +2266,8 @@ subroutine psb_d_mv_csc_from_coo(a,b,info)
logical :: rwshr_
Integer :: nza, nr, i,j,irw, err_act, nc, icl
Integer, Parameter :: maxtry=8
integer :: debug_level, debug_unit
character(len=20) :: name='csc_from_coo'
integer :: debug_level, debug_unit
character(len=20) :: name
info = psb_success_
debug_unit = psb_get_debug_unit()
@@ -2309,7 +2309,7 @@ subroutine psb_d_mv_csc_from_coo(a,b,info)
if (i >= icl) exit inner
if (i > nc) then
write(debug_unit,*) trim(name),&
& ' Strange situation: i>nr ',i,nc,j,nza,icl
& 'Strange situation: i>nr ',i,nc,j,nza,icl
exit outer
end if
a%icp(i+1) = a%icp(i)
@@ -2787,6 +2787,7 @@ subroutine psb_d_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc)
character(len=20) :: name='d_csc_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -2814,7 +2815,11 @@ subroutine psb_d_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nc
base/serial/impl/psb_d_csr_impl.f90
+272 -77
View File
@@ -26,7 +26,7 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc
real(psb_dpk_) :: acc
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='d_csr_csmv'
logical, parameter :: debug=.false.
@@ -47,9 +47,10 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans)
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra) then
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -72,7 +73,7 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans)
call psb_d_csr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,&
& a%is_triangle(),a%is_unit(),&
& x,beta,y,tra)
& x,beta,y,tra,ctra)
call psb_erractionrestore(err_act)
return
@@ -88,11 +89,11 @@ subroutine psb_d_csr_csmv(alpha,a,x,beta,y,info,trans)
contains
subroutine psb_d_csr_csmv_inner(m,n,alpha,irp,ja,val,is_triangle,is_unit,&
& x,beta,y,tra)
& x,beta,y,tra,ctra)
integer, intent(in) :: m,n,irp(*),ja(*)
real(psb_dpk_), intent(in) :: alpha, beta, x(*),val(*)
real(psb_dpk_), intent(inout) :: y(*)
logical, intent(in) :: is_triangle,is_unit,tra
logical, intent(in) :: is_triangle,is_unit,tra, ctra
integer :: i,j,k, ir, jc
@@ -112,7 +113,7 @@ contains
end if
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (beta == dzero) then
@@ -130,9 +131,9 @@ contains
do i=1,m
acc = dzero
do j=irp(i), irp(i+1)-1
acc = acc - val(j) * x(ja(j))
acc = acc + val(j) * x(ja(j))
enddo
y(i) = acc
y(i) = -acc
end do
else
@@ -162,11 +163,11 @@ contains
else if (alpha == -done) then
do i=1,m
acc = y(i)
acc = dzero
do j=irp(i), irp(i+1)-1
acc = acc - val(j) * x(ja(j))
acc = acc + val(j) * x(ja(j))
enddo
y(i) = acc
y(i) = y(i) -acc
end do
else
@@ -185,21 +186,21 @@ contains
if (alpha == done) then
do i=1,m
acc = -y(i)
acc = dzero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = acc
y(i) = -y(i) + acc
end do
else if (alpha == -done) then
do i=1,m
acc = y(i)
acc = dzero
do j=irp(i), irp(i+1)-1
acc = acc - val(j) * x(ja(j))
acc = acc + val(j) * x(ja(j))
enddo
y(i) = acc
y(i) = -y(i) -acc
end do
else
@@ -296,6 +297,53 @@ contains
end if
else if (ctra) then
if (beta == dzero) then
do i=1, m
y(i) = dzero
end do
else if (beta == done) then
! Do nothing
else if (beta == -done) then
do i=1, m
y(i) = -y(i)
end do
else
do i=1, m
y(i) = beta*y(i)
end do
end if
if (alpha == done) then
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir) = y(ir) + (val(j))*x(i)
end do
enddo
else if (alpha == -done) then
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir) = y(ir) - (val(j))*x(i)
end do
enddo
else
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir) = y(ir) + alpha*(val(j))*x(i)
end do
enddo
end if
endif
if (is_triangle.and.is_unit) then
@@ -324,7 +372,7 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc, nc
real(psb_dpk_), allocatable :: acc(:)
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='d_csr_csmm'
logical, parameter :: debug=.false.
@@ -343,9 +391,10 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra) then
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -376,7 +425,7 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans)
call psb_d_csr_csmm_inner(m,n,nc,alpha,a%irp,a%ja,a%val, &
& a%is_triangle(),a%is_unit(),x,size(x,1), &
& beta,y,size(y,1),tra,acc)
& beta,y,size(y,1),tra,ctra,acc)
call psb_erractionrestore(err_act)
@@ -392,11 +441,11 @@ subroutine psb_d_csr_csmm(alpha,a,x,beta,y,info,trans)
contains
subroutine psb_d_csr_csmm_inner(m,n,nc,alpha,irp,ja,val,&
& is_triangle,is_unit,x,ldx,beta,y,ldy,tra,acc)
& is_triangle,is_unit,x,ldx,beta,y,ldy,tra,ctra,acc)
integer, intent(in) :: m,n,ldx,ldy,nc,irp(*),ja(*)
real(psb_dpk_), intent(in) :: alpha, beta, x(ldx,*),val(*)
real(psb_dpk_), intent(inout) :: y(ldy,*)
logical, intent(in) :: is_triangle,is_unit,tra
logical, intent(in) :: is_triangle,is_unit,tra,ctra
real(psb_dpk_), intent(inout) :: acc(*)
integer :: i,j,k, ir, jc
@@ -415,8 +464,7 @@ contains
return
end if
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (beta == dzero) then
if (alpha == done) then
@@ -433,9 +481,9 @@ contains
do i=1,m
acc(1:nc) = dzero
do j=irp(i), irp(i+1)-1
acc(1:nc) = acc(1:nc) - val(j) * x(ja(j),1:nc)
acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc)
enddo
y(i,1:nc) = acc(1:nc)
y(i,1:nc) = -acc(1:nc)
end do
else
@@ -455,21 +503,21 @@ contains
if (alpha == done) then
do i=1,m
acc(1:nc) = y(i,1:nc)
acc(1:nc) = dzero
do j=irp(i), irp(i+1)-1
acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc)
enddo
y(i,1:nc) = acc(1:nc)
y(i,1:nc) = y(i,1:nc) + acc(1:nc)
end do
else if (alpha == -done) then
do i=1,m
acc(1:nc) = y(i,1:nc)
do i=1,m
acc(1:nc) = dzero
do j=irp(i), irp(i+1)-1
acc(1:nc) = acc(1:nc) - val(j) * x(ja(j),1:nc)
acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc)
enddo
y(i,1:nc) = acc(1:nc)
y(i,1:nc) = y(i,1:nc) -acc(1:nc)
end do
else
@@ -599,6 +647,53 @@ contains
end if
else if (ctra) then
if (beta == dzero) then
do i=1, m
y(i,1:nc) = dzero
end do
else if (beta == done) then
! Do nothing
else if (beta == -done) then
do i=1, m
y(i,1:nc) = -y(i,1:nc)
end do
else
do i=1, m
y(i,1:nc) = beta*y(i,1:nc)
end do
end if
if (alpha == done) then
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir,1:nc) = y(ir,1:nc) + (val(j))*x(i,1:nc)
end do
enddo
else if (alpha == -done) then
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir,1:nc) = y(ir,1:nc) - (val(j))*x(i,1:nc)
end do
enddo
else
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir,1:nc) = y(ir,1:nc) + alpha*(val(j))*x(i,1:nc)
end do
enddo
end if
endif
if (is_triangle.and.is_unit) then
@@ -627,7 +722,7 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m,n, nnz, ir, jc
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: tmp(:)
logical :: tra
logical :: tra,ctra
Integer :: err_act
character(len=20) :: name='d_csr_cssv'
logical, parameter :: debug=.false.
@@ -645,7 +740,8 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (.not. (a%is_triangle())) then
@@ -681,7 +777,7 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans)
if (beta == dzero) then
call inner_csrsv(tra,a%is_lower(),a%is_unit(),a%get_nrows(),&
call inner_csrsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),&
& a%irp,a%ja,a%val,x,y)
if (alpha == done) then
! do nothing
@@ -700,7 +796,7 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans)
return
end if
call inner_csrsv(tra,a%is_lower(),a%is_unit(),a%get_nrows(),&
call inner_csrsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),&
& a%irp,a%ja,a%val,x,tmp)
call psb_geaxpby(m,alpha,tmp,beta,y,info)
@@ -721,18 +817,18 @@ subroutine psb_d_csr_cssv(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_csrsv(tra,lower,unit,n,irp,ja,val,x,y)
subroutine inner_csrsv(tra,ctra,lower,unit,n,irp,ja,val,x,y)
implicit none
logical, intent(in) :: tra,lower,unit
integer, intent(in) :: irp(*), ja(*),n
real(psb_dpk_), intent(in) :: val(*)
real(psb_dpk_), intent(in) :: x(*)
real(psb_dpk_), intent(out) :: y(*)
logical, intent(in) :: tra,ctra,lower,unit
integer, intent(in) :: irp(*), ja(*),n
real(psb_dpk_), intent(in) :: val(*)
real(psb_dpk_), intent(in) :: x(*)
real(psb_dpk_), intent(out) :: y(*)
integer :: i,j,k,m, ir, jc
real(psb_dpk_) :: acc
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (lower) then
if (unit) then
@@ -821,6 +917,54 @@ contains
end if
end if
else if (ctra) then
do i=1, n
y(i) = x(i)
end do
if (lower) then
if (unit) then
do i=n, 1, -1
acc = y(i)
do j=irp(i), irp(i+1)-1
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
end do
end do
else if (.not.unit) then
do i=n, 1, -1
y(i) = y(i)/val(irp(i+1)-1)
acc = y(i)
do j=irp(i), irp(i+1)-2
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
end do
end do
end if
else if (.not.lower) then
if (unit) then
do i=1, n
acc = y(i)
do j=irp(i), irp(i+1)-1
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
end do
end do
else if (.not.unit) then
do i=1, n
y(i) = y(i)/val(irp(i))
acc = y(i)
do j=irp(i)+1, irp(i+1)-1
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
end do
end do
end if
end if
end if
end subroutine inner_csrsv
@@ -843,7 +987,7 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m,n, nnz, ir, jc, nc
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='d_csr_cssm'
logical, parameter :: debug=.false.
@@ -863,7 +1007,8 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans)
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
nc = min(size(x,2) , size(y,2))
@@ -889,7 +1034,7 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans)
end if
if (beta == dzero) then
call inner_csrsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
@@ -902,7 +1047,7 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans)
goto 9999
end if
call inner_csrsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),tmp,size(tmp,1),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
@@ -931,14 +1076,14 @@ subroutine psb_d_csr_cssm(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_csrsm(tra,lower,unit,nr,nc,&
subroutine inner_csrsm(tra,ctra,lower,unit,nr,nc,&
& irp,ja,val,x,ldx,y,ldy,info)
implicit none
logical, intent(in) :: tra,lower,unit
integer, intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*)
real(psb_dpk_), intent(in) :: val(*), x(ldx,*)
real(psb_dpk_), intent(out) :: y(ldy,*)
integer, intent(out) :: info
logical, intent(in) :: tra,ctra,lower,unit
integer, intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*)
real(psb_dpk_), intent(in) :: val(*), x(ldx,*)
real(psb_dpk_), intent(out) :: y(ldy,*)
integer, intent(out) :: info
integer :: i,j,k,m, ir, jc
real(psb_dpk_), allocatable :: acc(:)
@@ -950,8 +1095,7 @@ contains
end if
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (lower) then
if (unit) then
do i=1, nr
@@ -1039,12 +1183,59 @@ contains
end if
end if
else if (ctra) then
do i=1, nr
y(i,1:nc) = x(i,1:nc)
end do
if (lower) then
if (unit) then
do i=nr, 1, -1
acc = y(i,1:nc)
do j=irp(i), irp(i+1)-1
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc
end do
end do
else if (.not.unit) then
do i=nr, 1, -1
y(i,1:nc) = y(i,1:nc)/(val(irp(i+1)-1))
acc = y(i,1:nc)
do j=irp(i), irp(i+1)-2
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc
end do
end do
end if
else if (.not.lower) then
if (unit) then
do i=1, nr
acc = y(i,1:nc)
do j=irp(i), irp(i+1)-1
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc
end do
end do
else if (.not.unit) then
do i=1, nr
y(i,1:nc) = y(i,1:nc)/(val(irp(i)))
acc = y(i,1:nc)
do j=irp(i)+1, irp(i+1)-1
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc
end do
end do
end if
end if
end if
end subroutine inner_csrsm
end subroutine psb_d_csr_cssm
function psb_d_csr_maxval(a) result(res)
use psb_error_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_csr_maxval
@@ -1057,7 +1248,7 @@ function psb_d_csr_maxval(a) result(res)
logical, parameter :: debug=.false.
res = dzero
res = dzero
nnz = a%get_nzeros()
if (allocated(a%val)) then
nnz = min(nnz,size(a%val))
@@ -1080,7 +1271,7 @@ function psb_d_csr_csnmi(a) result(res)
logical, parameter :: debug=.false.
res = dzero
res = dzero
do i = 1, a%get_nrows()
acc = dzero
@@ -1092,7 +1283,6 @@ function psb_d_csr_csnmi(a) result(res)
end function psb_d_csr_csnmi
function psb_d_csr_csnm1(a) result(res)
use psb_error_mod
use psb_const_mod
@@ -1111,7 +1301,7 @@ function psb_d_csr_csnm1(a) result(res)
logical, parameter :: debug=.false.
res = -done
res = dzero
nnz = a%get_nzeros()
m = a%get_nrows()
n = a%get_ncols()
@@ -1333,7 +1523,6 @@ subroutine psb_d_csr_aclsum(d,a)
end subroutine psb_d_csr_aclsum
subroutine psb_d_csr_get_diag(a,d,info)
use psb_error_mod
use psb_const_mod
@@ -1359,7 +1548,7 @@ subroutine psb_d_csr_get_diag(a,d,info)
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = done
d(1:mnm) = done
else
do i=1, mnm
d(i) = dzero
@@ -1372,8 +1561,9 @@ subroutine psb_d_csr_get_diag(a,d,info)
end do
end if
do i=mnm+1,size(d)
d(i) = dzero
d(i) = czero
end do
call psb_erractionrestore(err_act)
return
@@ -1585,7 +1775,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()
@@ -2410,7 +2600,7 @@ subroutine psb_d_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc)
Integer :: err_act
character(len=20) :: name='d_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -2438,7 +2628,11 @@ subroutine psb_d_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nr
@@ -2497,10 +2691,10 @@ subroutine psb_d_cp_csr_from_coo(a,b,info)
integer :: debug_level, debug_unit
character(len=20) :: name
info = psb_success_
! This is to have fix_coo called behind the scenes
call b%cp_to_coo(tmp,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info)
info = psb_success_
! This is to have fix_coo called behind the scenes
call tmp%cp_from_coo(b,info)
if (info == psb_success_) call a%mv_from_coo(tmp,info)
end subroutine psb_d_cp_csr_from_coo
@@ -2608,8 +2802,8 @@ subroutine psb_d_mv_csr_from_coo(a,b,info)
logical :: rwshr_
Integer :: nza, nr, i,j,irw, err_act, nc
Integer, Parameter :: maxtry=8
integer :: debug_level, debug_unit
character(len=20) :: name='csr_mv_from_coo'
integer :: debug_level, debug_unit
character(len=20) :: name='mv_from_coo'
info = psb_success_
debug_unit = psb_get_debug_unit()
@@ -2618,9 +2812,11 @@ subroutine psb_d_mv_csr_from_coo(a,b,info)
call b%fix(info)
if (info /= psb_success_) return
nr = b%get_nrows()
nc = b%get_ncols()
nza = b%get_nzeros()
call a%psb_d_base_sparse_mat%mv_from(b%psb_d_base_sparse_mat)
! Dirty trick: call move_alloc to have the new data allocated just once.
@@ -2628,9 +2824,8 @@ subroutine psb_d_mv_csr_from_coo(a,b,info)
call move_alloc(b%ja,a%ja)
call move_alloc(b%val,a%val)
call psb_realloc(max(nr+1,nc+1),a%irp,info)
call b%free()
if (info /= psb_success_) return
if (nza <= 0) then
a%irp(:) = 1
else
@@ -2725,8 +2920,8 @@ end subroutine psb_d_mv_csr_to_fmt
subroutine psb_d_cp_csr_to_fmt(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_d_base_mat_mod
use psb_realloc_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_to_fmt
implicit none
@@ -2805,8 +3000,8 @@ end subroutine psb_d_mv_csr_from_fmt
subroutine psb_d_cp_csr_from_fmt(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_d_base_mat_mod
use psb_realloc_mod
use psb_d_csr_mat_mod, psb_protect_name => psb_d_cp_csr_from_fmt
implicit none
base/serial/impl/psb_d_mat_impl.F90
+2 -6
View File
@@ -1402,8 +1402,8 @@ subroutine psb_d_cp_from(a,b)
use psb_string_mod
use psb_d_mat_mod, psb_protect_name => psb_d_cp_from
implicit none
class(psb_dspmat_type), intent(out) :: a
class(psb_d_base_sparse_mat), intent(in) :: b
class(psb_dspmat_type), intent(out) :: a
class(psb_d_base_sparse_mat), intent(inout), allocatable :: b
Integer :: err_act, info
character(len=20) :: name='clone'
logical, parameter :: debug=.false.
@@ -2067,7 +2067,6 @@ function psb_d_csnmi(a) result(res)
character(len=20) :: name='csnmi'
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_
@@ -2289,7 +2288,6 @@ subroutine psb_d_get_diag(a,d,info)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = psb_err_invalid_mat_state_
@@ -2328,7 +2326,6 @@ subroutine psb_d_scal(d,a,info)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = psb_err_invalid_mat_state_
@@ -2367,7 +2364,6 @@ subroutine psb_d_scals(d,a,info)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = psb_err_invalid_mat_state_
base/serial/impl/psb_s_base_mat_impl.f90
+39 -9
View File
@@ -295,6 +295,11 @@ end subroutine psb_s_base_csgetrow
!
! Here we have the base implementation of getblk and clip:
! this is just based on the getrow.
! If performance is critical it can be overridden.
!
subroutine psb_s_base_csgetblk(imin,imax,a,b,info,&
& jmin,jmax,iren,append,rscale,cscale)
! Output is always in COO format
@@ -474,7 +479,7 @@ subroutine psb_s_base_transp_2mat(a,b)
implicit none
class(psb_s_base_sparse_mat), intent(in) :: a
class(psb_base_sparse_mat), intent(out) :: b
class(psb_base_sparse_mat), intent(out) :: b
type(psb_s_coo_sparse_mat) :: tmp
integer err_act, info
@@ -512,7 +517,8 @@ subroutine psb_s_base_transc_2mat(a,b)
implicit none
class(psb_s_base_sparse_mat), intent(in) :: a
class(psb_base_sparse_mat), intent(out) :: b
class(psb_base_sparse_mat), intent(out) :: b
type(psb_s_coo_sparse_mat) :: tmp
integer err_act, info
character(len=*), parameter :: name='s_base_transc'
@@ -583,7 +589,31 @@ subroutine psb_s_base_transc_1mat(a)
class(psb_s_base_sparse_mat), intent(inout) :: a
call a%transp()
type(psb_s_coo_sparse_mat) :: tmp
integer :: err_act, info
character(len=*), parameter :: name='s_base_transc'
call psb_erractionsave(err_act)
info = psb_success_
call a%mv_to_coo(tmp,info)
if (info == psb_success_) call tmp%transc()
if (info == psb_success_) call a%mv_from_coo(tmp,info)
if (info /= psb_success_) then
info = psb_err_missing_override_method_
call psb_errpush(info,name,a_err=a%get_fmt())
goto 9999
end if
call psb_erractionrestore(err_act)
return
9999 continue
if (err_act /= psb_act_ret_) then
call psb_error()
end if
return
end subroutine psb_s_base_transc_1mat
@@ -1062,6 +1092,7 @@ subroutine psb_s_base_scal(d,a,info)
end subroutine psb_s_base_scal
function psb_s_base_maxval(a) result(res)
use psb_error_mod
use psb_const_mod
@@ -1085,7 +1116,7 @@ function psb_s_base_maxval(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -sone
res = szero
return
@@ -1114,13 +1145,12 @@ function psb_s_base_csnmi(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -sone
res = szero
return
end function psb_s_base_csnmi
function psb_s_base_csnm1(a) result(res)
use psb_error_mod
use psb_const_mod
@@ -1144,7 +1174,7 @@ function psb_s_base_csnm1(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -sone
res = szero
return
@@ -1254,6 +1284,7 @@ subroutine psb_s_base_aclsum(d,a)
end subroutine psb_s_base_aclsum
subroutine psb_s_base_get_diag(a,d,info)
use psb_error_mod
use psb_const_mod
@@ -1284,12 +1315,11 @@ subroutine psb_s_base_get_diag(a,d,info)
end subroutine psb_s_base_get_diag
! == ==================================
!
!
!
! Computational routines for S_VECT
! Computational routines for s_VECT
! variables. If the actual data type is
! a "normal" one, these are sufficient.
!
base/serial/impl/psb_s_coo_impl.f90
+237 -28
View File
@@ -351,6 +351,7 @@ subroutine psb_s_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc)
character(len=20) :: name='s_coo_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -378,7 +379,11 @@ subroutine psb_s_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
@@ -476,7 +481,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m,n, nnz, ir, jc, nc
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: tmp(:,:)
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='s_base_csmm'
logical, parameter :: debug=.false.
@@ -502,7 +507,8 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
else
trans_ = 'N'
end if
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
@@ -532,7 +538,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
end if
if (beta == szero) then
call inner_coosm(tra,a%is_lower(),a%is_unit(),a%is_sorted(),&
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),y,size(y,1),info)
do i = 1, m
@@ -546,7 +552,7 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
goto 9999
end if
call inner_coosm(tra,a%is_lower(),a%is_unit(),a%is_sorted(),&
call inner_coosm(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& m,nc,nnz,a%ia,a%ja,a%val,&
& x,size(x,1),tmp,size(tmp,1),info)
do i = 1, m
@@ -576,10 +582,10 @@ subroutine psb_s_coo_cssm(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_coosm(tra,lower,unit,sorted,nr,nc,nz,&
subroutine inner_coosm(tra,ctra,lower,unit,sorted,nr,nc,nz,&
& ia,ja,val,x,ldx,y,ldy,info)
implicit none
logical, intent(in) :: tra,lower,unit,sorted
logical, intent(in) :: tra,ctra,lower,unit,sorted
integer, intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*)
real(psb_spk_), intent(in) :: val(*), x(ldx,*)
real(psb_spk_), intent(out) :: y(ldy,*)
@@ -603,7 +609,8 @@ contains
nnz = nz
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (lower) then
if (unit) then
@@ -739,6 +746,76 @@ contains
end if
end if
end if
else if (ctra) then
do i=1, nr
y(i,1:nc) = x(i,1:nc)
end do
if (lower) then
if (unit) then
j = nnz
do i=nr, 1, -1
acc(1:nc) = y(i,1:nc)
do
if (j < 1) exit
if (ia(j) < i) exit
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc)
j = j - 1
end do
end do
else if (.not.unit) then
j = nnz
do i=nr, 1, -1
if (ja(j) == i) then
y(i,1:nc) = y(i,1:nc) / (val(j))
j = j - 1
end if
acc(1:nc) = y(i,1:nc)
do
if (j < 1) exit
if (ia(j) < i) exit
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc)
j = j - 1
end do
end do
else if (.not.lower) then
if (unit) then
j = 1
do i=1, nr
acc(1:nc) = y(i,1:nc)
do
if (j > nnz) exit
if (ia(j) > i) exit
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc)
j = j + 1
end do
end do
else if (.not.unit) then
j = 1
do i=1, nr
if (ja(j) == i) then
y(i,1:nc) = y(i,1:nc) / (val(j))
j = j + 1
end if
acc(1:nc) = y(i,1:nc)
do
if (j > nnz) exit
if (ia(j) > i) exit
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc(1:nc)
j = j + 1
end do
end do
end if
end if
end if
end if
end subroutine inner_coosm
@@ -762,7 +839,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m,n, nnz, ir, jc
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: tmp(:)
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='s_coo_cssv_impl'
logical, parameter :: debug=.false.
@@ -781,7 +858,9 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (size(x,1) < m) then
info = 36
@@ -814,7 +893,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans)
end if
if (beta == szero) then
call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),&
call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,&
& x,y,info)
if (info /= psb_success_) then
@@ -832,7 +911,7 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
end if
call inner_coosv(tra,a%is_lower(),a%is_unit(),a%is_sorted(),&
call inner_coosv(tra,ctra,a%is_lower(),a%is_unit(),a%is_sorted(),&
& a%get_nrows(),a%get_nzeros(),a%ia,a%ja,a%val,&
& x,tmp,info)
if (info /= psb_success_) then
@@ -858,10 +937,10 @@ subroutine psb_s_coo_cssv(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_coosv(tra,lower,unit,sorted,nr,nz,&
subroutine inner_coosv(tra,ctra,lower,unit,sorted,nr,nz,&
& ia,ja,val,x,y,info)
implicit none
logical, intent(in) :: tra,lower,unit,sorted
logical, intent(in) :: tra,ctra,lower,unit,sorted
integer, intent(in) :: nr,nz,ia(*),ja(*)
real(psb_spk_), intent(in) :: val(*), x(*)
real(psb_spk_), intent(out) :: y(*)
@@ -878,7 +957,7 @@ contains
nnz = nz
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (lower) then
if (unit) then
@@ -1014,6 +1093,75 @@ contains
end if
end if
end if
else if (ctra) then
do i=1, nr
y(i) = x(i)
end do
if (lower) then
if (unit) then
j = nnz
do i=nr, 1, -1
acc = y(i)
do
if (j < 1) exit
if (ia(j) < i) exit
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
j = j - 1
end do
end do
else if (.not.unit) then
j = nnz
do i=nr, 1, -1
if (ja(j) == i) then
y(i) = y(i) /(val(j))
j = j - 1
end if
acc = y(i)
do
if (j < 1) exit
if (ia(j) < i) exit
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
j = j - 1
end do
end do
else if (.not.lower) then
if (unit) then
j = 1
do i=1, nr
acc = y(i)
do
if (j > nnz) exit
if (ia(j) > i) exit
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
j = j + 1
end do
end do
else if (.not.unit) then
j = 1
do i=1, nr
if (ja(j) == i) then
y(i) = y(i) /(val(j))
j = j + 1
end if
acc = y(i)
do
if (j > nnz) exit
if (ia(j) > i) exit
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
j = j + 1
end do
end do
end if
end if
end if
end if
end subroutine inner_coosv
@@ -1037,7 +1185,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc
real(psb_spk_) :: acc
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='s_coo_csmv_impl'
logical, parameter :: debug=.false.
@@ -1058,10 +1206,12 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans)
trans_ = 'N'
end if
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra) then
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -1123,7 +1273,7 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans)
end if
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
i = 1
j = i
if (nnz > 0) then
@@ -1172,6 +1322,34 @@ subroutine psb_s_coo_csmv(alpha,a,x,beta,y,info,trans)
end if !.....end testing on alpha
else if (ctra) then
if (alpha == sone) then
i = 1
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir) = y(ir) + (a%val(i))*x(jc)
enddo
else if (alpha == -sone) then
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir) = y(ir) - (a%val(i))*x(jc)
enddo
else
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir) = y(ir) + alpha*(a%val(i))*x(jc)
enddo
end if !.....end testing on alpha
endif
call psb_erractionrestore(err_act)
@@ -1204,7 +1382,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc, nc
real(psb_spk_), allocatable :: acc(:)
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='s_coo_csmm_impl'
logical, parameter :: debug=.false.
@@ -1227,9 +1405,11 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra) then
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -1323,6 +1503,7 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
else if (tra) then
if (alpha == sone) then
i = 1
do i=1,nnz
@@ -1349,6 +1530,34 @@ subroutine psb_s_coo_csmm(alpha,a,x,beta,y,info,trans)
end if !.....end testing on alpha
else if (ctra) then
if (alpha == sone) then
i = 1
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir,1:nc) = y(ir,1:nc) + (a%val(i))*x(jc,1:nc)
enddo
else if (alpha == -sone) then
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir,1:nc) = y(ir,1:nc) - (a%val(i))*x(jc,1:nc)
enddo
else
do i=1,nnz
ir = a%ja(i)
jc = a%ia(i)
y(ir,1:nc) = y(ir,1:nc) + alpha*(a%val(i))*x(jc,1:nc)
enddo
end if !.....end testing on alpha
endif
call psb_erractionrestore(err_act)
@@ -1373,7 +1582,7 @@ function psb_s_coo_maxval(a) result(res)
real(psb_spk_) :: res
integer :: i,j,k,m,n, nnz, ir, jc, nc, info
character(len=20) :: name='d_coo_maxval'
character(len=20) :: name='s_coo_maxval'
logical, parameter :: debug=.false.
@@ -1397,11 +1606,11 @@ function psb_s_coo_csnmi(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
Integer :: err_act
character(len=20) :: name='s_base_csnmi'
character(len=20) :: name='s_coo_csnmi'
logical, parameter :: debug=.false.
res = szero
res = szero
nnz = a%get_nzeros()
if (a%is_sorted()) then
i = 1
@@ -1430,7 +1639,7 @@ function psb_s_coo_csnmi(a) result(res)
res = maxval(vt(1:m))
deallocate(vt,stat=info)
end if
end function psb_s_coo_csnmi
@@ -1448,11 +1657,11 @@ function psb_s_coo_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
Integer :: err_act
character(len=20) :: name='d_coo_csnm1'
character(len=20) :: name='s_coo_csnm1'
logical, parameter :: debug=.false.
res = -sone
res = szero
nnz = a%get_nzeros()
n = a%get_ncols()
allocate(vt(n),stat=info)
base/serial/impl/psb_s_csc_impl.f90
+14 -7
View File
@@ -766,7 +766,6 @@ contains
else if (.not.lower) then
if (unit) then
do i=n, 1, -1
acc = y(i)
@@ -1034,7 +1033,7 @@ function psb_s_csc_maxval(a) result(res)
real(psb_spk_) :: res
integer :: i,j,k,m,n, nnz, ir, jc, nc, info
character(len=20) :: name='d_csc_maxval'
character(len=20) :: name='s_csc_maxval'
logical, parameter :: debug=.false.
@@ -1081,6 +1080,7 @@ function psb_s_csc_csnmi(a) result(res)
end function psb_s_csc_csnmi
function psb_s_csc_csnm1(a) result(res)
use psb_error_mod
use psb_const_mod
@@ -1095,7 +1095,7 @@ function psb_s_csc_csnm1(a) result(res)
real(psb_spk_), allocatable :: vt(:)
logical :: tra
Integer :: err_act
character(len=20) :: name='d_csc_csnm1'
character(len=20) :: name='s_csc_csnm1'
logical, parameter :: debug=.false.
@@ -1316,6 +1316,7 @@ subroutine psb_s_csc_arwsum(d,a)
end subroutine psb_s_csc_arwsum
subroutine psb_s_csc_get_diag(a,d,info)
use psb_error_mod
use psb_const_mod
@@ -1352,7 +1353,7 @@ subroutine psb_s_csc_get_diag(a,d,info)
endif
enddo
end do
end if
endif
do i=mnm+1,size(d)
d(i) = szero
end do
@@ -2265,8 +2266,8 @@ subroutine psb_s_mv_csc_from_coo(a,b,info)
logical :: rwshr_
Integer :: nza, nr, i,j,irw, err_act, nc, icl
Integer, Parameter :: maxtry=8
integer :: debug_level, debug_unit
character(len=20) :: name='csc_from_coo'
integer :: debug_level, debug_unit
character(len=20) :: name
info = psb_success_
debug_unit = psb_get_debug_unit()
@@ -2529,6 +2530,7 @@ subroutine psb_s_csc_mold(a,b,info)
end subroutine psb_s_csc_mold
subroutine psb_s_csc_reallocate_nz(nz,a)
use psb_error_mod
use psb_realloc_mod
@@ -2785,6 +2787,7 @@ subroutine psb_s_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc)
character(len=20) :: name='s_csc_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -2812,7 +2815,11 @@ subroutine psb_s_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nc
base/serial/impl/psb_s_csr_impl.f90
+262 -67
View File
@@ -26,7 +26,7 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc
real(psb_spk_) :: acc
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='s_csr_csmv'
logical, parameter :: debug=.false.
@@ -47,9 +47,10 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans)
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra) then
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -72,7 +73,7 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans)
call psb_s_csr_csmv_inner(m,n,alpha,a%irp,a%ja,a%val,&
& a%is_triangle(),a%is_unit(),&
& x,beta,y,tra)
& x,beta,y,tra,ctra)
call psb_erractionrestore(err_act)
return
@@ -88,11 +89,11 @@ subroutine psb_s_csr_csmv(alpha,a,x,beta,y,info,trans)
contains
subroutine psb_s_csr_csmv_inner(m,n,alpha,irp,ja,val,is_triangle,is_unit,&
& x,beta,y,tra)
& x,beta,y,tra,ctra)
integer, intent(in) :: m,n,irp(*),ja(*)
real(psb_spk_), intent(in) :: alpha, beta, x(*),val(*)
real(psb_spk_), intent(inout) :: y(*)
logical, intent(in) :: is_triangle,is_unit,tra
logical, intent(in) :: is_triangle,is_unit,tra, ctra
integer :: i,j,k, ir, jc
@@ -112,7 +113,7 @@ contains
end if
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (beta == szero) then
@@ -130,9 +131,9 @@ contains
do i=1,m
acc = szero
do j=irp(i), irp(i+1)-1
acc = acc - val(j) * x(ja(j))
acc = acc + val(j) * x(ja(j))
enddo
y(i) = acc
y(i) = -acc
end do
else
@@ -162,11 +163,11 @@ contains
else if (alpha == -sone) then
do i=1,m
acc = y(i)
acc = szero
do j=irp(i), irp(i+1)-1
acc = acc - val(j) * x(ja(j))
acc = acc + val(j) * x(ja(j))
enddo
y(i) = acc
y(i) = y(i) -acc
end do
else
@@ -185,21 +186,21 @@ contains
if (alpha == sone) then
do i=1,m
acc = -y(i)
acc = szero
do j=irp(i), irp(i+1)-1
acc = acc + val(j) * x(ja(j))
enddo
y(i) = acc
y(i) = -y(i) + acc
end do
else if (alpha == -sone) then
do i=1,m
acc = y(i)
acc = szero
do j=irp(i), irp(i+1)-1
acc = acc - val(j) * x(ja(j))
acc = acc + val(j) * x(ja(j))
enddo
y(i) = acc
y(i) = -y(i) -acc
end do
else
@@ -296,6 +297,53 @@ contains
end if
else if (ctra) then
if (beta == szero) then
do i=1, m
y(i) = szero
end do
else if (beta == sone) then
! Do nothing
else if (beta == -sone) then
do i=1, m
y(i) = -y(i)
end do
else
do i=1, m
y(i) = beta*y(i)
end do
end if
if (alpha == sone) then
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir) = y(ir) + (val(j))*x(i)
end do
enddo
else if (alpha == -sone) then
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir) = y(ir) - (val(j))*x(i)
end do
enddo
else
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir) = y(ir) + alpha*(val(j))*x(i)
end do
enddo
end if
endif
if (is_triangle.and.is_unit) then
@@ -324,7 +372,7 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc, nc
real(psb_spk_), allocatable :: acc(:)
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='s_csr_csmm'
logical, parameter :: debug=.false.
@@ -343,9 +391,10 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans)
call psb_errpush(info,name)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra) then
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -376,7 +425,7 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans)
call psb_s_csr_csmm_inner(m,n,nc,alpha,a%irp,a%ja,a%val, &
& a%is_triangle(),a%is_unit(),x,size(x,1), &
& beta,y,size(y,1),tra,acc)
& beta,y,size(y,1),tra,ctra,acc)
call psb_erractionrestore(err_act)
@@ -392,11 +441,11 @@ subroutine psb_s_csr_csmm(alpha,a,x,beta,y,info,trans)
contains
subroutine psb_s_csr_csmm_inner(m,n,nc,alpha,irp,ja,val,&
& is_triangle,is_unit,x,ldx,beta,y,ldy,tra,acc)
& is_triangle,is_unit,x,ldx,beta,y,ldy,tra,ctra,acc)
integer, intent(in) :: m,n,ldx,ldy,nc,irp(*),ja(*)
real(psb_spk_), intent(in) :: alpha, beta, x(ldx,*),val(*)
real(psb_spk_), intent(inout) :: y(ldy,*)
logical, intent(in) :: is_triangle,is_unit,tra
logical, intent(in) :: is_triangle,is_unit,tra,ctra
real(psb_spk_), intent(inout) :: acc(*)
integer :: i,j,k, ir, jc
@@ -415,8 +464,7 @@ contains
return
end if
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (beta == szero) then
if (alpha == sone) then
@@ -433,9 +481,9 @@ contains
do i=1,m
acc(1:nc) = szero
do j=irp(i), irp(i+1)-1
acc(1:nc) = acc(1:nc) - val(j) * x(ja(j),1:nc)
acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc)
enddo
y(i,1:nc) = acc(1:nc)
y(i,1:nc) = -acc(1:nc)
end do
else
@@ -455,21 +503,21 @@ contains
if (alpha == sone) then
do i=1,m
acc(1:nc) = y(i,1:nc)
acc(1:nc) = szero
do j=irp(i), irp(i+1)-1
acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc)
enddo
y(i,1:nc) = acc(1:nc)
y(i,1:nc) = y(i,1:nc) + acc(1:nc)
end do
else if (alpha == -sone) then
do i=1,m
acc(1:nc) = y(i,1:nc)
do i=1,m
acc(1:nc) = szero
do j=irp(i), irp(i+1)-1
acc(1:nc) = acc(1:nc) - val(j) * x(ja(j),1:nc)
acc(1:nc) = acc(1:nc) + val(j) * x(ja(j),1:nc)
enddo
y(i,1:nc) = acc(1:nc)
y(i,1:nc) = y(i,1:nc) -acc(1:nc)
end do
else
@@ -599,6 +647,53 @@ contains
end if
else if (ctra) then
if (beta == szero) then
do i=1, m
y(i,1:nc) = szero
end do
else if (beta == sone) then
! Do nothing
else if (beta == -sone) then
do i=1, m
y(i,1:nc) = -y(i,1:nc)
end do
else
do i=1, m
y(i,1:nc) = beta*y(i,1:nc)
end do
end if
if (alpha == sone) then
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir,1:nc) = y(ir,1:nc) + (val(j))*x(i,1:nc)
end do
enddo
else if (alpha == -sone) then
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir,1:nc) = y(ir,1:nc) - (val(j))*x(i,1:nc)
end do
enddo
else
do i=1,n
do j=irp(i), irp(i+1)-1
ir = ja(j)
y(ir,1:nc) = y(ir,1:nc) + alpha*(val(j))*x(i,1:nc)
end do
enddo
end if
endif
if (is_triangle.and.is_unit) then
@@ -627,7 +722,7 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m,n, nnz, ir, jc
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: tmp(:)
logical :: tra
logical :: tra,ctra
Integer :: err_act
character(len=20) :: name='s_csr_cssv'
logical, parameter :: debug=.false.
@@ -645,7 +740,8 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
if (.not. (a%is_triangle())) then
@@ -681,7 +777,7 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans)
if (beta == szero) then
call inner_csrsv(tra,a%is_lower(),a%is_unit(),a%get_nrows(),&
call inner_csrsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),&
& a%irp,a%ja,a%val,x,y)
if (alpha == sone) then
! do nothing
@@ -700,7 +796,7 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans)
return
end if
call inner_csrsv(tra,a%is_lower(),a%is_unit(),a%get_nrows(),&
call inner_csrsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),&
& a%irp,a%ja,a%val,x,tmp)
call psb_geaxpby(m,alpha,tmp,beta,y,info)
@@ -721,18 +817,18 @@ subroutine psb_s_csr_cssv(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_csrsv(tra,lower,unit,n,irp,ja,val,x,y)
subroutine inner_csrsv(tra,ctra,lower,unit,n,irp,ja,val,x,y)
implicit none
logical, intent(in) :: tra,lower,unit
integer, intent(in) :: irp(*), ja(*),n
real(psb_spk_), intent(in) :: val(*)
real(psb_spk_), intent(in) :: x(*)
real(psb_spk_), intent(out) :: y(*)
logical, intent(in) :: tra,ctra,lower,unit
integer, intent(in) :: irp(*), ja(*),n
real(psb_spk_), intent(in) :: val(*)
real(psb_spk_), intent(in) :: x(*)
real(psb_spk_), intent(out) :: y(*)
integer :: i,j,k,m, ir, jc
real(psb_spk_) :: acc
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (lower) then
if (unit) then
@@ -821,6 +917,54 @@ contains
end if
end if
else if (ctra) then
do i=1, n
y(i) = x(i)
end do
if (lower) then
if (unit) then
do i=n, 1, -1
acc = y(i)
do j=irp(i), irp(i+1)-1
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
end do
end do
else if (.not.unit) then
do i=n, 1, -1
y(i) = y(i)/val(irp(i+1)-1)
acc = y(i)
do j=irp(i), irp(i+1)-2
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
end do
end do
end if
else if (.not.lower) then
if (unit) then
do i=1, n
acc = y(i)
do j=irp(i), irp(i+1)-1
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
end do
end do
else if (.not.unit) then
do i=1, n
y(i) = y(i)/val(irp(i))
acc = y(i)
do j=irp(i)+1, irp(i+1)-1
jc = ja(j)
y(jc) = y(jc) - (val(j))*acc
end do
end do
end if
end if
end if
end subroutine inner_csrsv
@@ -843,7 +987,7 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m,n, nnz, ir, jc, nc
real(psb_spk_) :: acc
real(psb_spk_), allocatable :: tmp(:,:)
logical :: tra
logical :: tra, ctra
Integer :: err_act
character(len=20) :: name='s_csr_cssm'
logical, parameter :: debug=.false.
@@ -863,7 +1007,8 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans)
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
nc = min(size(x,2) , size(y,2))
@@ -889,7 +1034,7 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans)
end if
if (beta == szero) then
call inner_csrsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),y,size(y,1),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
@@ -902,7 +1047,7 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans)
goto 9999
end if
call inner_csrsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
call inner_csrsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%irp,a%ja,a%val,x,size(x,1),tmp,size(tmp,1),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
@@ -931,14 +1076,14 @@ subroutine psb_s_csr_cssm(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_csrsm(tra,lower,unit,nr,nc,&
subroutine inner_csrsm(tra,ctra,lower,unit,nr,nc,&
& irp,ja,val,x,ldx,y,ldy,info)
implicit none
logical, intent(in) :: tra,lower,unit
integer, intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*)
real(psb_spk_), intent(in) :: val(*), x(ldx,*)
real(psb_spk_), intent(out) :: y(ldy,*)
integer, intent(out) :: info
logical, intent(in) :: tra,ctra,lower,unit
integer, intent(in) :: nr,nc,ldx,ldy,irp(*),ja(*)
real(psb_spk_), intent(in) :: val(*), x(ldx,*)
real(psb_spk_), intent(out) :: y(ldy,*)
integer, intent(out) :: info
integer :: i,j,k,m, ir, jc
real(psb_spk_), allocatable :: acc(:)
@@ -950,8 +1095,7 @@ contains
end if
if (.not.tra) then
if ((.not.tra).and.(.not.ctra)) then
if (lower) then
if (unit) then
do i=1, nr
@@ -1039,6 +1183,54 @@ contains
end if
end if
else if (ctra) then
do i=1, nr
y(i,1:nc) = x(i,1:nc)
end do
if (lower) then
if (unit) then
do i=nr, 1, -1
acc = y(i,1:nc)
do j=irp(i), irp(i+1)-1
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc
end do
end do
else if (.not.unit) then
do i=nr, 1, -1
y(i,1:nc) = y(i,1:nc)/(val(irp(i+1)-1))
acc = y(i,1:nc)
do j=irp(i), irp(i+1)-2
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc
end do
end do
end if
else if (.not.lower) then
if (unit) then
do i=1, nr
acc = y(i,1:nc)
do j=irp(i), irp(i+1)-1
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc
end do
end do
else if (.not.unit) then
do i=1, nr
y(i,1:nc) = y(i,1:nc)/(val(irp(i)))
acc = y(i,1:nc)
do j=irp(i)+1, irp(i+1)-1
jc = ja(j)
y(jc,1:nc) = y(jc,1:nc) - (val(j))*acc
end do
end do
end if
end if
end if
end subroutine inner_csrsm
@@ -1052,11 +1244,11 @@ function psb_s_csr_maxval(a) result(res)
real(psb_spk_) :: res
integer :: i,j,k,m,n, nnz, ir, jc, nc, info
character(len=20) :: name='d_csr_maxval'
character(len=20) :: name='s_csr_maxval'
logical, parameter :: debug=.false.
res = szero
res = szero
nnz = a%get_nzeros()
if (allocated(a%val)) then
nnz = min(nnz,size(a%val))
@@ -1064,7 +1256,6 @@ function psb_s_csr_maxval(a) result(res)
end if
end function psb_s_csr_maxval
function psb_s_csr_csnmi(a) result(res)
use psb_error_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_csr_csnmi
@@ -1080,10 +1271,10 @@ function psb_s_csr_csnmi(a) result(res)
logical, parameter :: debug=.false.
res = szero
res = szero
do i = 1, a%get_nrows()
acc = szero
acc = dzero
do j=a%irp(i),a%irp(i+1)-1
acc = acc + abs(a%val(j))
end do
@@ -1357,7 +1548,7 @@ subroutine psb_s_csr_get_diag(a,d,info)
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = sone
d(1:mnm) = sone
else
do i=1, mnm
d(i) = szero
@@ -1370,8 +1561,9 @@ subroutine psb_s_csr_get_diag(a,d,info)
end do
end if
do i=mnm+1,size(d)
d(i) = szero
d(i) = czero
end do
call psb_erractionrestore(err_act)
return
@@ -2408,7 +2600,7 @@ subroutine psb_s_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc)
Integer :: err_act
character(len=20) :: name='s_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='real'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -2436,7 +2628,11 @@ subroutine psb_s_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nr
@@ -2804,8 +3000,8 @@ end subroutine psb_s_mv_csr_from_fmt
subroutine psb_s_cp_csr_from_fmt(a,b,info)
use psb_const_mod
use psb_realloc_mod
use psb_s_base_mat_mod
use psb_realloc_mod
use psb_s_csr_mat_mod, psb_protect_name => psb_s_cp_csr_from_fmt
implicit none
@@ -2864,7 +3060,6 @@ subroutine psb_s_csr_cp_from(a,b)
call psb_safe_cpy( b%ja , a%ja , info)
call psb_safe_cpy( b%val, a%val , info)
if (info /= psb_success_) goto 9999
call psb_erractionrestore(err_act)
return
base/serial/impl/psb_s_mat_impl.F90
+9 -6
View File
@@ -1022,6 +1022,13 @@ subroutine psb_s_cscnv(a,b,info,type,mold,upd,dupl)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
call b%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call b%set_dupl(psb_dupl_def_)
end if
if (count( (/present(mold),present(type) /)) > 1) then
info = psb_err_many_optional_arg_
call psb_errpush(info,name,a_err='TYPE, MOLD')
@@ -1402,8 +1409,8 @@ subroutine psb_s_cp_from(a,b)
use psb_string_mod
use psb_s_mat_mod, psb_protect_name => psb_s_cp_from
implicit none
class(psb_sspmat_type), intent(out) :: a
class(psb_s_base_sparse_mat), intent(in) :: b
class(psb_sspmat_type), intent(out) :: a
class(psb_s_base_sparse_mat), intent(inout), allocatable :: b
Integer :: err_act, info
character(len=20) :: name='clone'
logical, parameter :: debug=.false.
@@ -2067,7 +2074,6 @@ function psb_s_csnmi(a) result(res)
character(len=20) :: name='csnmi'
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_
@@ -2289,7 +2295,6 @@ subroutine psb_s_get_diag(a,d,info)
character(len=20) :: name='get_diag'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = psb_err_invalid_mat_state_
@@ -2328,7 +2333,6 @@ subroutine psb_s_scal(d,a,info)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = psb_err_invalid_mat_state_
@@ -2367,7 +2371,6 @@ subroutine psb_s_scals(d,a,info)
character(len=20) :: name='scal'
logical, parameter :: debug=.false.
info = psb_success_
call psb_erractionsave(err_act)
if (.not.allocated(a%a)) then
info = psb_err_invalid_mat_state_
base/serial/impl/psb_z_base_mat_impl.f90
+31 -29
View File
@@ -295,6 +295,11 @@ end subroutine psb_z_base_csgetrow
!
! Here we have the base implementation of getblk and clip:
! this is just based on the getrow.
! If performance is critical it can be overridden.
!
subroutine psb_z_base_csgetblk(imin,imax,a,b,info,&
& jmin,jmax,iren,append,rscale,cscale)
! Output is always in COO format
@@ -468,14 +473,13 @@ subroutine psb_z_base_mold(a,b,info)
end subroutine psb_z_base_mold
subroutine psb_z_base_transp_2mat(a,b)
use psb_z_base_mat_mod, psb_protect_name => psb_z_base_transp_2mat
use psb_error_mod
implicit none
class(psb_z_base_sparse_mat), intent(in) :: a
class(psb_base_sparse_mat), intent(out) :: b
class(psb_base_sparse_mat), intent(out) :: b
type(psb_z_coo_sparse_mat) :: tmp
integer err_act, info
@@ -513,7 +517,8 @@ subroutine psb_z_base_transc_2mat(a,b)
implicit none
class(psb_z_base_sparse_mat), intent(in) :: a
class(psb_base_sparse_mat), intent(out) :: b
class(psb_base_sparse_mat), intent(out) :: b
type(psb_z_coo_sparse_mat) :: tmp
integer err_act, info
character(len=*), parameter :: name='z_base_transc'
@@ -542,7 +547,6 @@ subroutine psb_z_base_transc_2mat(a,b)
end if
return
end subroutine psb_z_base_transc_2mat
subroutine psb_z_base_transp_1mat(a)
@@ -584,6 +588,7 @@ subroutine psb_z_base_transc_1mat(a)
implicit none
class(psb_z_base_sparse_mat), intent(inout) :: a
type(psb_z_coo_sparse_mat) :: tmp
integer :: err_act, info
character(len=*), parameter :: name='z_base_transc'
@@ -1087,6 +1092,7 @@ subroutine psb_z_base_scal(d,a,info)
end subroutine psb_z_base_scal
function psb_z_base_maxval(a) result(res)
use psb_error_mod
use psb_const_mod
@@ -1110,7 +1116,7 @@ function psb_z_base_maxval(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -done
res = dzero
return
@@ -1139,7 +1145,7 @@ function psb_z_base_csnmi(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -done
res = dzero
return
@@ -1168,7 +1174,7 @@ function psb_z_base_csnm1(a) result(res)
if (err_act /= psb_act_ret_) then
call psb_error()
end if
res = -sone
res = dzero
return
@@ -1179,7 +1185,7 @@ subroutine psb_z_base_rowsum(d,a)
use psb_const_mod
use psb_z_base_mat_mod, psb_protect_name => psb_z_base_rowsum
class(psb_z_base_sparse_mat), intent(in) :: a
complex(psb_dpk_), intent(out) :: d(:)
complex(psb_dpk_), intent(out) :: d(:)
Integer :: err_act, info
character(len=20) :: name='rowsum'
@@ -1231,7 +1237,7 @@ subroutine psb_z_base_colsum(d,a)
use psb_const_mod
use psb_z_base_mat_mod, psb_protect_name => psb_z_base_colsum
class(psb_z_base_sparse_mat), intent(in) :: a
complex(psb_dpk_), intent(out) :: d(:)
complex(psb_dpk_), intent(out) :: d(:)
Integer :: err_act, info
character(len=20) :: name='colsum'
@@ -1278,6 +1284,7 @@ subroutine psb_z_base_aclsum(d,a)
end subroutine psb_z_base_aclsum
subroutine psb_z_base_get_diag(a,d,info)
use psb_error_mod
use psb_const_mod
@@ -1308,14 +1315,11 @@ subroutine psb_z_base_get_diag(a,d,info)
end subroutine psb_z_base_get_diag
! == ==================================
!
!
!
! Computational routines for Z_VECT
! Computational routines for z_VECT
! variables. If the actual data type is
! a "normal" one, these are sufficient.
!
@@ -1331,12 +1335,12 @@ subroutine psb_z_base_vect_mv(alpha,a,x,beta,y,info,trans)
use psb_const_mod
use psb_z_base_mat_mod, psb_protect_name => psb_z_base_vect_mv
implicit none
class(psb_z_base_sparse_mat), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta
class(psb_z_base_sparse_mat), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta
class(psb_z_base_vect_type), intent(inout) :: x
class(psb_z_base_vect_type), intent(inout) :: y
integer, intent(out) :: info
character, optional, intent(in) :: trans
integer, intent(out) :: info
character, optional, intent(in) :: trans
! For the time being we just throw everything back
! onto the normal routines.
@@ -1352,18 +1356,18 @@ subroutine psb_z_base_vect_cssv(alpha,a,x,beta,y,info,trans,scale,d)
use psb_error_mod
use psb_string_mod
implicit none
class(psb_z_base_sparse_mat), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta
class(psb_z_base_sparse_mat), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta
class(psb_z_base_vect_type), intent(inout) :: x,y
integer, intent(out) :: info
character, optional, intent(in) :: trans, scale
integer, intent(out) :: info
character, optional, intent(in) :: trans, scale
class(psb_z_base_vect_type), intent(inout),optional :: d
complex(psb_dpk_), allocatable :: tmp(:)
class(psb_z_base_vect_type), allocatable :: tmpv
Integer :: err_act, nar,nac,nc, i
character(len=1) :: scale_
character(len=20) :: name='s_cssm'
character(len=20) :: name='z_cssm'
logical, parameter :: debug=.false.
call psb_erractionsave(err_act)
@@ -1491,14 +1495,14 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
use psb_string_mod
use psb_z_base_vect_mod
implicit none
class(psb_z_base_sparse_mat), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta
class(psb_z_base_sparse_mat), intent(in) :: a
complex(psb_dpk_), intent(in) :: alpha, beta
class(psb_z_base_vect_type), intent(inout) :: x, y
integer, intent(out) :: info
character, optional, intent(in) :: trans
integer, intent(out) :: info
character, optional, intent(in) :: trans
Integer :: err_act
character(len=20) :: name='s_base_inner_vect_sv'
character(len=20) :: name='z_base_inner_vect_sv'
logical, parameter :: debug=.false.
call psb_get_erraction(err_act)
@@ -1530,5 +1534,3 @@ subroutine psb_z_base_inner_vect_sv(alpha,a,x,beta,y,info,trans)
return
end subroutine psb_z_base_inner_vect_sv
base/serial/impl/psb_z_coo_impl.f90
+54 -29
View File
@@ -351,6 +351,7 @@ subroutine psb_z_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc)
character(len=20) :: name='z_coo_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -378,7 +379,11 @@ subroutine psb_z_coo_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do j=1,a%get_nzeros()
@@ -582,8 +587,8 @@ contains
implicit none
logical, intent(in) :: tra,ctra,lower,unit,sorted
integer, intent(in) :: nr,nc,nz,ldx,ldy,ia(*),ja(*)
complex(psb_dpk_), intent(in) :: val(*), x(ldx,*)
complex(psb_dpk_), intent(out) :: y(ldy,*)
complex(psb_dpk_), intent(in) :: val(*), x(ldx,*)
complex(psb_dpk_), intent(out) :: y(ldy,*)
integer, intent(out) :: info
integer :: i,j,k,m, ir, jc
@@ -604,6 +609,7 @@ contains
nnz = nz
if ((.not.tra).and.(.not.ctra)) then
if (lower) then
@@ -764,7 +770,7 @@ contains
j = nnz
do i=nr, 1, -1
if (ja(j) == i) then
y(i,1:nc) = y(i,1:nc) /conjg(val(j))
y(i,1:nc) = y(i,1:nc) / conjg(val(j))
j = j - 1
end if
acc(1:nc) = y(i,1:nc)
@@ -794,7 +800,7 @@ contains
j = 1
do i=1, nr
if (ja(j) == i) then
y(i,1:nc) = y(i,1:nc) /conjg(val(j))
y(i,1:nc) = y(i,1:nc) / conjg(val(j))
j = j + 1
end if
acc(1:nc) = y(i,1:nc)
@@ -809,6 +815,7 @@ contains
end if
end if
end if
end if
end subroutine inner_coosm
@@ -851,6 +858,7 @@ subroutine psb_z_coo_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
m = a%get_nrows()
@@ -934,8 +942,8 @@ contains
implicit none
logical, intent(in) :: tra,ctra,lower,unit,sorted
integer, intent(in) :: nr,nz,ia(*),ja(*)
complex(psb_dpk_), intent(in) :: val(*), x(*)
complex(psb_dpk_), intent(out) :: y(*)
complex(psb_dpk_), intent(in) :: val(*), x(*)
complex(psb_dpk_), intent(out) :: y(*)
integer, intent(out) :: info
integer :: i,j,k,m, ir, jc, nnz
@@ -1198,11 +1206,11 @@ subroutine psb_z_coo_csmv(alpha,a,x,beta,y,info,trans)
trans_ = 'N'
end if
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra.or.ctra) then
m = a%get_ncols()
n = a%get_nrows()
@@ -1473,7 +1481,7 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
if ((.not.tra).and.(.not.ctra)) then
if (.not.tra) then
i = 1
j = i
if (nnz > 0) then
@@ -1495,6 +1503,7 @@ subroutine psb_z_coo_csmm(alpha,a,x,beta,y,info,trans)
end if
else if (tra) then
if (alpha == zone) then
i = 1
do i=1,nnz
@@ -1573,7 +1582,7 @@ function psb_z_coo_maxval(a) result(res)
real(psb_dpk_) :: res
integer :: i,j,k,m,n, nnz, ir, jc, nc, info
character(len=20) :: name='c_coo_maxval'
character(len=20) :: name='z_coo_maxval'
logical, parameter :: debug=.false.
@@ -1592,30 +1601,45 @@ function psb_z_coo_csnmi(a) result(res)
class(psb_z_coo_sparse_mat), intent(in) :: a
real(psb_dpk_) :: res
integer :: i,j,k,m,n, nnz, ir, jc, nc
integer :: i,j,k,m,n, nnz, ir, jc, nc, info
real(psb_dpk_) :: acc
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
Integer :: err_act
character(len=20) :: name='z_base_csnmi'
character(len=20) :: name='z_coo_csnmi'
logical, parameter :: debug=.false.
res = dzero
res = dzero
nnz = a%get_nzeros()
i = 1
j = i
do while (i<=nnz)
do while ((a%ia(j) == a%ia(i)).and. (j <= nnz))
j = j+1
enddo
acc = dzero
do k=i, j-1
acc = acc + abs(a%val(k))
if (a%is_sorted()) then
i = 1
j = i
res = dzero
do while (i<=nnz)
do while ((a%ia(j) == a%ia(i)).and. (j <= nnz))
j = j+1
enddo
acc = dzero
do k=i, j-1
acc = acc + abs(a%val(k))
end do
res = max(res,acc)
i = j
end do
res = max(res,acc)
i = j
end do
else
m = a%get_nrows()
allocate(vt(m),stat=info)
if (info /= 0) return
vt(:) = dzero
do j=1, nnz
i = a%ia(j)
vt(i) = vt(i) + abs(a%val(j))
end do
res = maxval(vt(1:m))
deallocate(vt,stat=info)
end if
end function psb_z_coo_csnmi
@@ -1633,7 +1657,7 @@ function psb_z_coo_csnm1(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
Integer :: err_act
character(len=20) :: name='d_coo_csnm1'
character(len=20) :: name='z_coo_csnm1'
logical, parameter :: debug=.false.
@@ -1708,7 +1732,7 @@ subroutine psb_z_coo_arwsum(d,a)
use psb_const_mod
use psb_z_base_mat_mod, psb_protect_name => psb_z_coo_arwsum
class(psb_z_coo_sparse_mat), intent(in) :: a
real(psb_dpk_), intent(out) :: d(:)
real(psb_dpk_), intent(out) :: d(:)
integer :: i,j,k,m,n, nnz, ir, jc, nc
real(psb_dpk_) :: acc
@@ -1779,7 +1803,7 @@ subroutine psb_z_coo_colsum(d,a)
goto 9999
end if
d = zzero
d = zzero
nnz = a%get_nzeros()
do j=1, nnz
k = a%ja(j)
@@ -1851,6 +1875,7 @@ subroutine psb_z_coo_aclsum(d,a)
end subroutine psb_z_coo_aclsum
! == ==================================
!
!
base/serial/impl/psb_z_csc_impl.f90
+65 -423
View File
@@ -26,7 +26,7 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc
complex(psb_dpk_) :: acc
logical :: tra, ctra
logical :: tra
Integer :: err_act
character(len=20) :: name='z_csc_csmv'
logical, parameter :: debug=.false.
@@ -47,11 +47,9 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans)
endif
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra.or.ctra) then
if (tra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -223,144 +221,7 @@ subroutine psb_z_csc_csmv(alpha,a,x,beta,y,info,trans)
end if
else if (ctra) then
if (beta == zzero) then
if (alpha == zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = acc
end do
else if (alpha == -zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = -acc
end do
else
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = alpha*acc
end do
end if
else if (beta == zone) then
if (alpha == zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = y(i) + acc
end do
else if (alpha == -zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = y(i) -acc
end do
else
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = y(i) + alpha*acc
end do
end if
else if (beta == -zone) then
if (alpha == zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = -y(i) + acc
end do
else if (alpha == -zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = -y(i) -acc
end do
else
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = -y(i) + alpha*acc
end do
end if
else
if (alpha == zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = beta*y(i) + acc
end do
else if (alpha == -zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = beta*y(i) - acc
end do
else
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j))
enddo
y(i) = beta*y(i) + alpha*acc
end do
end if
end if
else if (.not.(tra.or.ctra)) then
else if (.not.tra) then
if (beta == zzero) then
do i=1, m
@@ -442,7 +303,7 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans)
character :: trans_
integer :: i,j,k,m,n, nnz, ir, jc, nc
complex(psb_dpk_), allocatable :: acc(:)
logical :: tra, ctra
logical :: tra
Integer :: err_act
character(len=20) :: name='z_csc_csmm'
logical, parameter :: debug=.false.
@@ -456,16 +317,14 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans)
trans_ = 'N'
end if
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
if (.not.a%is_asb()) then
info = psb_err_invalid_mat_state_
call psb_errpush(info,name)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
if (tra.or.ctra) then
if (tra) then
m = a%get_ncols()
n = a%get_nrows()
else
@@ -645,144 +504,7 @@ subroutine psb_z_csc_csmm(alpha,a,x,beta,y,info,trans)
end if
else if (ctra) then
if (beta == zzero) then
if (alpha == zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = acc
end do
else if (alpha == -zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = -acc
end do
else
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = alpha*acc
end do
end if
else if (beta == zone) then
if (alpha == zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = y(i,:) + acc
end do
else if (alpha == -zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = y(i,:) -acc
end do
else
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = y(i,:) + alpha*acc
end do
end if
else if (beta == -zone) then
if (alpha == zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = -y(i,:) + acc
end do
else if (alpha == -zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = -y(i,:) -acc
end do
else
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = -y(i,:) + alpha*acc
end do
end if
else
if (alpha == zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = beta*y(i,:) + acc
end do
else if (alpha == -zone) then
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = beta*y(i,:) - acc
end do
else
do i=1,m
acc = zzero
do j=a%icp(i), a%icp(i+1)-1
acc = acc + conjg(a%val(j)) * x(a%ia(j),:)
enddo
y(i,:) = beta*y(i,:) + alpha*acc
end do
end if
end if
else if (.not.(tra.or.ctra)) then
else if (.not.tra) then
if (beta == zzero) then
do i=1, m
@@ -866,7 +588,7 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m, nnz, ir, jc
complex(psb_dpk_) :: acc
complex(psb_dpk_), allocatable :: tmp(:)
logical :: tra, ctra
logical :: tra
Integer :: err_act
character(len=20) :: name='z_csc_cssv'
logical, parameter :: debug=.false.
@@ -884,9 +606,7 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans)
goto 9999
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
if (.not. (a%is_triangle())) then
@@ -923,7 +643,7 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans)
end if
if (beta == zzero) then
call inner_cscsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),&
call inner_cscsv(tra,a%is_lower(),a%is_unit(),a%get_nrows(),&
& a%icp,a%ia,a%val,x,y)
if (alpha == zone) then
! do nothing
@@ -942,7 +662,7 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans)
return
end if
tmp(1:m) = x(1:m)
call inner_cscsv(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),&
call inner_cscsv(tra,a%is_lower(),a%is_unit(),a%get_nrows(),&
& a%icp,a%ia,a%val,tmp,y)
do i = 1, m
y(i) = alpha*tmp(i) + beta*y(i)
@@ -963,9 +683,9 @@ subroutine psb_z_csc_cssv(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_cscsv(tra,ctra,lower,unit,n,icp,ia,val,x,y)
subroutine inner_cscsv(tra,lower,unit,n,icp,ia,val,x,y)
implicit none
logical, intent(in) :: tra,ctra,lower,unit
logical, intent(in) :: tra,lower,unit
integer, intent(in) :: icp(*), ia(*),n
complex(psb_dpk_), intent(in) :: val(*)
complex(psb_dpk_), intent(in) :: x(*)
@@ -1014,53 +734,10 @@ contains
y(i) = (x(i) - acc)/val(icp(i+1)-1)
end do
end if
end if
else if (ctra) then
if (lower) then
if (unit) then
do i=n, 1, -1
acc = zzero
do j=icp(i), icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j))
end do
y(i) = x(i) - acc
end do
else if (.not.unit) then
do i=n, 1, -1
acc = zzero
do j=icp(i)+1, icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j))
end do
y(i) = (x(i) - acc)/conjg(val(icp(i)))
end do
end if
else if (.not.lower) then
if (unit) then
do i=1, n
acc = zzero
do j=icp(i), icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j))
end do
y(i) = x(i) - acc
end do
else if (.not.unit) then
do i=1, n
acc = zzero
do j=icp(i), icp(i+1)-2
acc = acc + conjg(val(j))*y(ia(j))
end do
y(i) = (x(i) - acc)/conjg(val(icp(i+1)-1))
end do
end if
end if
else if (.not.(tra.or.ctra)) then
else if (.not.tra) then
do i=1, n
y(i) = x(i)
@@ -1131,7 +808,7 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
integer :: i,j,k,m,n, nnz, ir, jc, nc
complex(psb_dpk_) :: acc
complex(psb_dpk_), allocatable :: tmp(:,:)
logical :: tra, ctra
logical :: tra
Integer :: err_act
character(len=20) :: name='z_base_csmm'
logical, parameter :: debug=.false.
@@ -1151,11 +828,8 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
endif
tra = (psb_toupper(trans_) == 'T')
ctra = (psb_toupper(trans_) == 'C')
tra = (psb_toupper(trans_) == 'T').or.(psb_toupper(trans_)=='C')
m = a%get_nrows()
nc = min(size(x,2) , size(y,2))
if (size(x,1)<m) then
info = 36
@@ -1169,6 +843,7 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
goto 9999
end if
nc = min(size(x,2) , size(y,2))
if (.not. (a%is_triangle())) then
info = psb_err_invalid_mat_state_
@@ -1191,7 +866,7 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
end if
if (beta == zzero) then
call inner_cscsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,x,size(x,1),y,size(y,1),info)
do i = 1, m
y(i,1:nc) = alpha*y(i,1:nc)
@@ -1205,7 +880,7 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
end if
tmp(1:m,:) = x(1:m,1:nc)
call inner_cscsm(tra,ctra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
call inner_cscsm(tra,a%is_lower(),a%is_unit(),a%get_nrows(),nc,&
& a%icp,a%ia,a%val,tmp,size(tmp,1),y,size(y,1),info)
do i = 1, m
y(i,1:nc) = alpha*tmp(i,1:nc) + beta*y(i,1:nc)
@@ -1234,10 +909,10 @@ subroutine psb_z_csc_cssm(alpha,a,x,beta,y,info,trans)
contains
subroutine inner_cscsm(tra,ctra,lower,unit,nr,nc,&
subroutine inner_cscsm(tra,lower,unit,nr,nc,&
& icp,ia,val,x,ldx,y,ldy,info)
implicit none
logical, intent(in) :: tra,ctra,lower,unit
logical, intent(in) :: tra,lower,unit
integer, intent(in) :: nr,nc,ldx,ldy,icp(*),ia(*)
complex(psb_dpk_), intent(in) :: val(*), x(ldx,*)
complex(psb_dpk_), intent(out) :: y(ldy,*)
@@ -1256,25 +931,6 @@ contains
if (tra) then
if (lower) then
if (unit) then
do i=1, nr
acc = zzero
do j=icp(i), icp(i+1)-1
acc = acc + val(j)*y(ia(j),1:nc)
end do
y(i,1:nc) = x(i,1:nc) - acc
end do
else if (.not.unit) then
do i=1, nr
acc = zzero
do j=icp(i), icp(i+1)-2
acc = acc + val(j)*y(ia(j),1:nc)
end do
y(i,1:nc) = (x(i,1:nc) - acc)/val(icp(i+1)-1)
end do
end if
else if (.not.lower) then
if (unit) then
do i=nr, 1, -1
acc = zzero
@@ -1293,16 +949,13 @@ contains
end do
end if
end if
else if (.not.lower) then
else if (ctra) then
if (lower) then
if (unit) then
do i=1, nr
acc = zzero
do j=icp(i), icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j),1:nc)
acc = acc + val(j)*y(ia(j),1:nc)
end do
y(i,1:nc) = x(i,1:nc) - acc
end do
@@ -1310,40 +963,43 @@ contains
do i=1, nr
acc = zzero
do j=icp(i), icp(i+1)-2
acc = acc + conjg(val(j))*y(ia(j),1:nc)
acc = acc + val(j)*y(ia(j),1:nc)
end do
y(i,1:nc) = (x(i,1:nc) - acc)/conjg(val(icp(i+1)-1))
end do
end if
else if (.not.lower) then
if (unit) then
do i=nr, 1, -1
acc = zzero
do j=icp(i), icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j),1:nc)
end do
y(i,1:nc) = x(i,1:nc) - acc
end do
else if (.not.unit) then
do i=nr, 1, -1
acc = zzero
do j=icp(i)+1, icp(i+1)-1
acc = acc + conjg(val(j))*y(ia(j),1:nc)
end do
y(i,1:nc) = (x(i,1:nc) - acc)/conjg(val(icp(i)))
y(i,1:nc) = (x(i,1:nc) - acc)/val(icp(i+1)-1)
end do
end if
end if
else if (.not.(tra.or.ctra)) then
else if (.not.tra) then
do i=1, nr
y(i,1:nc) = x(i,1:nc)
end do
if (lower) then
if (lower) then
if (unit) then
do i=1, nr
acc = y(i,1:nc)
do j=icp(i), icp(i+1)-1
jc = ia(j)
y(jc,1:nc) = y(jc,1:nc) - val(j)*acc
end do
end do
else if (.not.unit) then
do i=1, nr
y(i,1:nc) = y(i,1:nc)/val(icp(i))
acc = y(i,1:nc)
do j=icp(i)+1, icp(i+1)-1
jc = ia(j)
y(jc,1:nc) = y(jc,1:nc) - val(j)*acc
end do
end do
end if
else if (.not.lower) then
if (unit) then
do i=nr, 1, -1
acc = y(i,1:nc)
@@ -1362,26 +1018,6 @@ contains
end do
end do
end if
else if (.not.lower) then
if (unit) then
do i=1, nr
acc = y(i,1:nc)
do j=icp(i), icp(i+1)-1
jc = ia(j)
y(jc,1:nc) = y(jc,1:nc) - val(j)*acc
end do
end do
else if (.not.unit) then
do i=1, nr
y(i,1:nc) = y(i,1:nc)/val(icp(i))
acc = y(i,1:nc)
do j=icp(i)+1, icp(i+1)-1
jc = ia(j)
y(jc,1:nc) = y(jc,1:nc) - val(j)*acc
end do
end do
end if
end if
end if
@@ -1459,7 +1095,7 @@ function psb_z_csc_csnm1(a) result(res)
real(psb_dpk_), allocatable :: vt(:)
logical :: tra
Integer :: err_act
character(len=20) :: name='d_csc_csnm1'
character(len=20) :: name='z_csc_csnm1'
logical, parameter :: debug=.false.
@@ -1717,7 +1353,7 @@ subroutine psb_z_csc_get_diag(a,d,info)
endif
enddo
end do
end if
endif
do i=mnm+1,size(d)
d(i) = zzero
end do
@@ -2630,8 +2266,8 @@ subroutine psb_z_mv_csc_from_coo(a,b,info)
logical :: rwshr_
Integer :: nza, nr, i,j,irw, err_act, nc, icl
Integer, Parameter :: maxtry=8
integer :: debug_level, debug_unit
character(len=20) :: name='csc_from_coo'
integer :: debug_level, debug_unit
character(len=20) :: name
info = psb_success_
debug_unit = psb_get_debug_unit()
@@ -2775,13 +2411,13 @@ subroutine psb_z_cp_csc_to_fmt(a,b,info)
type is (psb_z_csc_sparse_mat)
call b%psb_z_base_sparse_mat%cp_from(a%psb_z_base_sparse_mat)
b%icp = a%icp
b%ia = a%ia
b%val = a%val
call psb_safe_cpy( a%icp, b%icp , info)
call psb_safe_cpy( a%ia , b%ia , info)
call psb_safe_cpy( a%val, b%val , info)
class default
call a%cp_to_coo(tmp,info)
if (info == psb_success_) call b%mv_from_coo(tmp,info)
end select
end subroutine psb_z_cp_csc_to_fmt
@@ -2894,6 +2530,7 @@ subroutine psb_z_csc_mold(a,b,info)
end subroutine psb_z_csc_mold
subroutine psb_z_csc_reallocate_nz(nz,a)
use psb_error_mod
use psb_realloc_mod
@@ -3150,6 +2787,7 @@ subroutine psb_z_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc)
character(len=20) :: name='z_csc_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -3177,7 +2815,11 @@ subroutine psb_z_csc_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nc
base/serial/impl/psb_z_csr_impl.f90
+12 -7
View File
@@ -1,5 +1,4 @@
! == ===================================
!
!
@@ -1249,7 +1248,7 @@ function psb_z_csr_maxval(a) result(res)
logical, parameter :: debug=.false.
res = dzero
res = dzero
nnz = a%get_nzeros()
if (allocated(a%val)) then
nnz = min(nnz,size(a%val))
@@ -1272,7 +1271,7 @@ function psb_z_csr_csnmi(a) result(res)
logical, parameter :: debug=.false.
res = dzero
res = dzero
do i = 1, a%get_nrows()
acc = dzero
@@ -1547,8 +1546,9 @@ subroutine psb_z_csr_get_diag(a,d,info)
goto 9999
end if
if (a%is_triangle().and.a%is_unit()) then
d(1:mnm) = zone
d(1:mnm) = zone
else
do i=1, mnm
d(i) = zzero
@@ -1561,8 +1561,9 @@ subroutine psb_z_csr_get_diag(a,d,info)
end do
end if
do i=mnm+1,size(d)
d(i) = zzero
d(i) = czero
end do
call psb_erractionrestore(err_act)
return
@@ -2599,7 +2600,7 @@ subroutine psb_z_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc)
Integer :: err_act
character(len=20) :: name='z_csr_print'
logical, parameter :: debug=.false.
character(len=*), parameter :: datatype='complex'
character(len=80) :: frmtv
integer :: irs,ics,i,j, nmx, ni, nr, nc, nz
@@ -2627,7 +2628,11 @@ subroutine psb_z_csr_print(iout,a,iv,eirs,eics,head,ivr,ivc)
nmx = max(nr,nc,1)
ni = floor(log10(1.0*nmx)) + 1
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
if (datatype=='real') then
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))'
else
write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))'
end if
write(iout,*) nr, nc, nz
if(present(iv)) then
do i=1, nr
base/serial/impl/psb_z_mat_impl.F90
+9 -2
View File
@@ -1022,6 +1022,13 @@ subroutine psb_z_cscnv(a,b,info,type,mold,upd,dupl)
call psb_errpush(info,name)
goto 9999
endif
if (present(dupl)) then
call b%set_dupl(dupl)
else if (a%is_bld()) then
! Does this make sense at all?? Who knows..
call b%set_dupl(psb_dupl_def_)
end if
if (count( (/present(mold),present(type) /)) > 1) then
info = psb_err_many_optional_arg_
call psb_errpush(info,name,a_err='TYPE, MOLD')
@@ -1402,8 +1409,8 @@ subroutine psb_z_cp_from(a,b)
use psb_string_mod
use psb_z_mat_mod, psb_protect_name => psb_z_cp_from
implicit none
class(psb_zspmat_type), intent(out) :: a
class(psb_z_base_sparse_mat), intent(in) :: b
class(psb_zspmat_type), intent(out) :: a
class(psb_z_base_sparse_mat), intent(inout), allocatable :: b
Integer :: err_act, info
character(len=20) :: name='clone'
logical, parameter :: debug=.false.
krylov/psb_dbicg.f90
+234 -234
View File
@@ -94,240 +94,240 @@
! estimate of) residual.
!
!
subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod
use psb_prec_mod
use psb_d_inner_krylov_mod
use psb_krylov_mod
implicit none
type(psb_dspmat_type), intent(in) :: a
class(psb_dprec_type), intent(in) :: prec
type(psb_desc_type), intent(in) :: desc_a
real(psb_dpk_), intent(in) :: b(:)
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(in) :: eps
integer, intent(out) :: info
integer, optional, intent(in) :: itmax, itrace, istop
integer, optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
!!$ local data
real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:)
real(psb_dpk_), pointer :: ww(:), q(:),&
& r(:), p(:), zt(:), pt(:), z(:), rt(:),qt(:)
integer :: int_err(5)
integer ::itmax_, naux, mglob, it, itrace_,&
& np,me, n_row, n_col, istop_, err_act
integer :: debug_level, debug_unit
logical, parameter :: exchange=.true., noexchange=.false.
integer, parameter :: irmax = 8
integer :: itx, isvch, ictxt
real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma
type(psb_itconv_type) :: stopdat
character(len=20) :: name,ch_err
character(len=*), parameter :: methdname='BiCG'
info = psb_success_
name = 'psb_dbicg'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),': from psb_info',np
mglob = desc_a%get_global_rows()
n_row = desc_a%get_local_rows()
n_col = desc_a%get_local_cols()
! Ensure global coherence for convergence checks.
call psb_set_coher(ictxt,isvch)
if (present(istop)) then
istop_ = istop
else
istop_ = 2
endif
!
! istop_ = 1: normwise backward error, infinity norm
! istop_ = 2: ||r||/||b|| norm 2
!
if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
info=psb_err_invalid_istop_
int_err=istop_
err=info
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_chkvect on X')
goto 9999
end if
call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_chkvect on B')
goto 9999
end if
naux=4*n_col
allocate(aux(naux),stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_non_
ch_err='psb_asb'
err=info
call psb_errpush(info,name,a_err=ch_err)
goto 9999
end if
q => wwrk(:,1)
qt => wwrk(:,2)
r => wwrk(:,3)
rt => wwrk(:,4)
p => wwrk(:,5)
pt => wwrk(:,6)
z => wwrk(:,7)
zt => wwrk(:,8)
ww => wwrk(:,9)
if (present(itmax)) then
itmax_ = itmax
else
itmax_ = 1000
endif
if (present(itrace)) then
itrace_ = itrace
else
itrace_ = 0
end if
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
restart: do
!!$
!!$ r0 = b-ax0
!!$
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),' Done spmm',info
if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
rho = dzero
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
iteration: do
it = it + 1
itx = itx + 1
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),'iteration: ',itx
call prec%apply(r,z,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='t',work=aux)
rho_old = rho
rho = psb_gedot(rt,z,desc_a,info)
if (rho == dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' iteration breakdown r',rho
exit iteration
endif
if (it == 1) then
call psb_geaxpby(done,z,dzero,p,desc_a,info)
call psb_geaxpby(done,zt,dzero,pt,desc_a,info)
else
beta = (rho/rho_old)
call psb_geaxpby(done,z,beta,p,desc_a,info)
call psb_geaxpby(done,zt,beta,pt,desc_a,info)
end if
call psb_spmm(done,a,p,dzero,q,desc_a,info,&
& work=aux)
call psb_spmm(done,a,pt,dzero,qt,desc_a,info,&
& work=aux,trans='t')
sigma = psb_gedot(pt,q,desc_a,info)
if (sigma == dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' iteration breakdown s1', sigma
exit iteration
endif
alpha = rho/sigma
call psb_geaxpby(alpha,p,done,x,desc_a,info)
call psb_geaxpby(-alpha,q,done,r,desc_a,info)
call psb_geaxpby(-alpha,qt,done,rt,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
end do iteration
end do restart
call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter)
deallocate(aux, stat=info)
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
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_dbicg
!!$subroutine psb_dbicg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
!!$ use psb_base_mod
!!$ use psb_prec_mod
!!$ use psb_d_inner_krylov_mod
!!$ use psb_krylov_mod
!!$ implicit none
!!$ type(psb_dspmat_type), intent(in) :: a
!!$
!!$ class(psb_dprec_type), intent(in) :: prec
!!$ type(psb_desc_type), intent(in) :: desc_a
!!$ real(psb_dpk_), intent(in) :: b(:)
!!$ real(psb_dpk_), intent(inout) :: x(:)
!!$ real(psb_dpk_), intent(in) :: eps
!!$ integer, intent(out) :: info
!!$ integer, optional, intent(in) :: itmax, itrace, istop
!!$ integer, optional, intent(out) :: iter
!!$ real(psb_dpk_), optional, intent(out) :: err
!!$! !$ local data
!!$ real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:)
!!$ real(psb_dpk_), pointer :: ww(:), q(:),&
!!$ & r(:), p(:), zt(:), pt(:), z(:), rt(:),qt(:)
!!$ integer :: int_err(5)
!!$ integer ::itmax_, naux, mglob, it, itrace_,&
!!$ & np,me, n_row, n_col, istop_, err_act
!!$ integer :: debug_level, debug_unit
!!$ logical, parameter :: exchange=.true., noexchange=.false.
!!$ integer, parameter :: irmax = 8
!!$ integer :: itx, isvch, ictxt
!!$ real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma
!!$ type(psb_itconv_type) :: stopdat
!!$ character(len=20) :: name,ch_err
!!$ character(len=*), parameter :: methdname='BiCG'
!!$
!!$ info = psb_success_
!!$ name = 'psb_dbicg'
!!$ call psb_erractionsave(err_act)
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$
!!$ ictxt = desc_a%get_context()
!!$ call psb_info(ictxt, me, np)
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np
!!$
!!$ mglob = desc_a%get_global_rows()
!!$ n_row = desc_a%get_local_rows()
!!$ n_col = desc_a%get_local_cols()
!!$
!!$ ! Ensure global coherence for convergence checks.
!!$ call psb_set_coher(ictxt,isvch)
!!$
!!$
!!$ if (present(istop)) then
!!$ istop_ = istop
!!$ else
!!$ istop_ = 2
!!$ endif
!!$ !
!!$ ! istop_ = 1: normwise backward error, infinity norm
!!$ ! istop_ = 2: ||r||/||b|| norm 2
!!$ !
!!$
!!$ if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
!!$ info=psb_err_invalid_istop_
!!$ int_err=istop_
!!$ err=info
!!$ call psb_errpush(info,name,i_err=int_err)
!!$ goto 9999
!!$ endif
!!$
!!$ call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_chkvect on X')
!!$ goto 9999
!!$ end if
!!$ call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_chkvect on B')
!!$ goto 9999
!!$ end if
!!$
!!$
!!$ naux=4*n_col
!!$
!!$ allocate(aux(naux),stat=info)
!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=9)
!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info)
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ ch_err='psb_asb'
!!$ err=info
!!$ call psb_errpush(info,name,a_err=ch_err)
!!$ goto 9999
!!$ end if
!!$
!!$ q => wwrk(:,1)
!!$ qt => wwrk(:,2)
!!$ r => wwrk(:,3)
!!$ rt => wwrk(:,4)
!!$ p => wwrk(:,5)
!!$ pt => wwrk(:,6)
!!$ z => wwrk(:,7)
!!$ zt => wwrk(:,8)
!!$ ww => wwrk(:,9)
!!$
!!$ if (present(itmax)) then
!!$ itmax_ = itmax
!!$ else
!!$ itmax_ = 1000
!!$ endif
!!$
!!$ if (present(itrace)) then
!!$ itrace_ = itrace
!!$ else
!!$ itrace_ = 0
!!$ end if
!!$
!!$ itx = 0
!!$
!!$
!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info)
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ restart: do
!!$! !$
!!$! !$ r0 = b-ax0
!!$! !$
!!$ if (itx >= itmax_) exit restart
!!$ it = 0
!!$ call psb_geaxpby(done,b,dzero,r,desc_a,info)
!!$ if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),' Done spmm',info
!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt,desc_a,info)
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ rho = dzero
!!$
!!$ ! Perhaps we already satisfy the convergence criterion...
!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ iteration: do
!!$ it = it + 1
!!$ itx = itx + 1
!!$
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx
!!$
!!$ call prec%apply(r,z,desc_a,info,work=aux)
!!$ if (info == psb_success_) call prec%apply(rt,zt,desc_a,info,trans='t',work=aux)
!!$
!!$ rho_old = rho
!!$ rho = psb_gedot(rt,z,desc_a,info)
!!$ if (rho == dzero) then
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' iteration breakdown r',rho
!!$ exit iteration
!!$ endif
!!$
!!$ if (it == 1) then
!!$ call psb_geaxpby(done,z,dzero,p,desc_a,info)
!!$ call psb_geaxpby(done,zt,dzero,pt,desc_a,info)
!!$ else
!!$ beta = (rho/rho_old)
!!$ call psb_geaxpby(done,z,beta,p,desc_a,info)
!!$ call psb_geaxpby(done,zt,beta,pt,desc_a,info)
!!$ end if
!!$
!!$ call psb_spmm(done,a,p,dzero,q,desc_a,info,&
!!$ & work=aux)
!!$ call psb_spmm(done,a,pt,dzero,qt,desc_a,info,&
!!$ & work=aux,trans='t')
!!$
!!$ sigma = psb_gedot(pt,q,desc_a,info)
!!$ if (sigma == dzero) then
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' iteration breakdown s1', sigma
!!$ exit iteration
!!$ endif
!!$
!!$ alpha = rho/sigma
!!$
!!$
!!$ call psb_geaxpby(alpha,p,done,x,desc_a,info)
!!$ call psb_geaxpby(-alpha,q,done,r,desc_a,info)
!!$ call psb_geaxpby(-alpha,qt,done,rt,desc_a,info)
!!$
!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ end do iteration
!!$ end do restart
!!$
!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter)
!!$
!!$ deallocate(aux, stat=info)
!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ ! restore external global coherence behaviour
!!$ call psb_restore_coher(ictxt,isvch)
!!$
!!$ 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_dbicg
subroutine psb_dbicg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
krylov/psb_dcg.F90
+225 -225
View File
@@ -95,231 +95,231 @@
! estimate of) residual.
!
!
subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond)
use psb_base_mod
use psb_prec_mod
use psb_d_inner_krylov_mod
use psb_krylov_mod
implicit none
type(psb_dspmat_type), intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_dprec_type), Intent(in) :: prec
Real(psb_dpk_), Intent(in) :: b(:)
Real(psb_dpk_), Intent(inout) :: x(:)
Real(psb_dpk_), Intent(in) :: eps
integer, intent(out) :: info
Integer, Optional, Intent(in) :: itmax, itrace, istop
Integer, Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
!!$ Local data
real(psb_dpk_), allocatable, target :: aux(:), wwrk(:,:),&
& td(:),tu(:),eig(:),ewrk(:)
integer, allocatable :: ibl(:), ispl(:), iwrk(:)
real(psb_dpk_), pointer :: q(:), p(:), r(:), z(:), w(:)
real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
integer :: itmax_, istop_, naux, mglob, it, itx, itrace_,&
& np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5), ieg,nspl, istebz
integer :: debug_level, debug_unit
type(psb_itconv_type) :: stopdat
logical :: do_cond
character(len=20) :: name
character(len=*), parameter :: methdname='CG'
info = psb_success_
name = 'psb_dcg'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
mglob = desc_a%get_global_rows()
n_row = desc_a%get_local_rows()
n_col = desc_a%get_local_cols()
if (present(istop)) then
istop_ = istop
else
istop_ = 2
endif
call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_chkvect on X/B')
goto 9999
end if
naux=4*n_col
allocate(aux(naux), stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=psb_err_invalid_input_)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
p => wwrk(:,1)
q => wwrk(:,2)
r => wwrk(:,3)
z => wwrk(:,4)
w => wwrk(:,5)
if (present(itmax)) then
itmax_ = itmax
else
itmax_ = 1000
endif
if (present(itrace)) then
itrace_ = itrace
else
itrace_ = 0
end if
do_cond=present(cond)
if (do_cond) then
istebz = 0
allocate(td(itmax_),tu(itmax_), eig(itmax_),&
& ibl(itmax_),ispl(itmax_),iwrk(3*itmax_),ewrk(4*itmax_),&
& stat=info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
end if
itx=0
! Ensure global coherence for convergence checks.
call psb_set_coher(ictxt,isvch)
restart: do
!!$
!!$ r0 = b-Ax0
!!$
if (itx>= itmax_) exit restart
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
rho = dzero
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
iteration: do
it = it + 1
itx = itx + 1
call prec%apply(r,z,desc_a,info,work=aux)
rho_old = rho
rho = psb_gedot(r,z,desc_a,info)
if (it == 1) then
call psb_geaxpby(done,z,dzero,p,desc_a,info)
else
if (rho_old == dzero) then
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),&
& ': CG Iteration breakdown rho'
exit iteration
endif
beta = rho/rho_old
call psb_geaxpby(done,z,beta,p,desc_a,info)
end if
call psb_spmm(done,a,p,dzero,q,desc_a,info,work=aux)
sigma = psb_gedot(p,q,desc_a,info)
if (sigma == dzero) then
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),&
& ': CG Iteration breakdown sigma'
exit iteration
endif
alpha_old = alpha
alpha = rho/sigma
if (do_cond) then
istebz = istebz + 1
if (istebz == 1) then
td(istebz) = done/alpha
else
td(istebz) = done/alpha + beta/alpha_old
tu(istebz-1) = sqrt(beta)/alpha_old
end if
end if
call psb_geaxpby(alpha,p,done,x,desc_a,info)
call psb_geaxpby(-alpha,q,done,r,desc_a,info)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
end do iteration
end do restart
if (do_cond) then
if (me == 0) then
#if defined(HAVE_LAPACK)
call dstebz('A','E',istebz,dzero,dzero,0,0,-done,td,tu,&
& ieg,nspl,eig,ibl,ispl,ewrk,iwrk,info)
if (info < 0) then
call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='dstebz',i_err=(/info,0,0,0,0/))
info = psb_err_from_subroutine_ai_
goto 9999
end if
cond = eig(ieg)/eig(1)
#else
cond = -1.0
#endif
info = psb_success_
end if
call psb_bcast(ictxt,cond,root=0)
end if
call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter)
call psb_gefree(wwrk,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
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_dcg
!!$subroutine psb_dcg(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop,cond)
!!$ use psb_base_mod
!!$ use psb_prec_mod
!!$ use psb_d_inner_krylov_mod
!!$ use psb_krylov_mod
!!$ implicit none
!!$ type(psb_dspmat_type), intent(in) :: a
!!$ Type(psb_desc_type), Intent(in) :: desc_a
!!$ class(psb_dprec_type), Intent(in) :: prec
!!$ Real(psb_dpk_), Intent(in) :: b(:)
!!$ Real(psb_dpk_), Intent(inout) :: x(:)
!!$ Real(psb_dpk_), Intent(in) :: eps
!!$ integer, intent(out) :: info
!!$ Integer, Optional, Intent(in) :: itmax, itrace, istop
!!$ Integer, Optional, Intent(out) :: iter
!!$ Real(psb_dpk_), Optional, Intent(out) :: err,cond
!!$! !$ Local data
!!$ real(psb_dpk_), allocatable, target :: aux(:), wwrk(:,:),&
!!$ & td(:),tu(:),eig(:),ewrk(:)
!!$ integer, allocatable :: ibl(:), ispl(:), iwrk(:)
!!$ real(psb_dpk_), pointer :: q(:), p(:), r(:), z(:), w(:)
!!$ real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma,alpha_old,beta_old
!!$ integer :: itmax_, istop_, naux, mglob, it, itx, itrace_,&
!!$ & np,me, n_col, isvch, ictxt, n_row,err_act, int_err(5), ieg,nspl, istebz
!!$ integer :: debug_level, debug_unit
!!$ type(psb_itconv_type) :: stopdat
!!$ logical :: do_cond
!!$ character(len=20) :: name
!!$ character(len=*), parameter :: methdname='CG'
!!$
!!$ info = psb_success_
!!$ name = 'psb_dcg'
!!$ call psb_erractionsave(err_act)
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$
!!$ ictxt = desc_a%get_context()
!!$
!!$ call psb_info(ictxt, me, np)
!!$
!!$
!!$ mglob = desc_a%get_global_rows()
!!$ n_row = desc_a%get_local_rows()
!!$ n_col = desc_a%get_local_cols()
!!$
!!$
!!$ if (present(istop)) then
!!$ istop_ = istop
!!$ else
!!$ istop_ = 2
!!$ endif
!!$
!!$ call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
!!$ if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B')
!!$ goto 9999
!!$ end if
!!$
!!$ naux=4*n_col
!!$ allocate(aux(naux), stat=info)
!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=psb_err_invalid_input_)
!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ p => wwrk(:,1)
!!$ q => wwrk(:,2)
!!$ r => wwrk(:,3)
!!$ z => wwrk(:,4)
!!$ w => wwrk(:,5)
!!$
!!$
!!$ if (present(itmax)) then
!!$ itmax_ = itmax
!!$ else
!!$ itmax_ = 1000
!!$ endif
!!$
!!$ if (present(itrace)) then
!!$ itrace_ = itrace
!!$ else
!!$ itrace_ = 0
!!$ end if
!!$
!!$ do_cond=present(cond)
!!$ if (do_cond) then
!!$ istebz = 0
!!$ allocate(td(itmax_),tu(itmax_), eig(itmax_),&
!!$ & ibl(itmax_),ispl(itmax_),iwrk(3*itmax_),ewrk(4*itmax_),&
!!$ & stat=info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ end if
!!$
!!$ itx=0
!!$
!!$ ! Ensure global coherence for convergence checks.
!!$ call psb_set_coher(ictxt,isvch)
!!$
!!$ restart: do
!!$! !$
!!$! !$ r0 = b-Ax0
!!$! !$
!!$ if (itx>= itmax_) exit restart
!!$
!!$ it = 0
!!$ call psb_geaxpby(done,b,dzero,r,desc_a,info)
!!$ if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ rho = dzero
!!$
!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info)
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ iteration: do
!!$
!!$ it = it + 1
!!$ itx = itx + 1
!!$
!!$ call prec%apply(r,z,desc_a,info,work=aux)
!!$ rho_old = rho
!!$ rho = psb_gedot(r,z,desc_a,info)
!!$
!!$ if (it == 1) then
!!$ call psb_geaxpby(done,z,dzero,p,desc_a,info)
!!$ else
!!$ if (rho_old == dzero) then
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ': CG Iteration breakdown rho'
!!$ exit iteration
!!$ endif
!!$ beta = rho/rho_old
!!$ call psb_geaxpby(done,z,beta,p,desc_a,info)
!!$ end if
!!$
!!$ call psb_spmm(done,a,p,dzero,q,desc_a,info,work=aux)
!!$ sigma = psb_gedot(p,q,desc_a,info)
!!$ if (sigma == dzero) then
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ': CG Iteration breakdown sigma'
!!$ exit iteration
!!$ endif
!!$ alpha_old = alpha
!!$ alpha = rho/sigma
!!$ if (do_cond) then
!!$ istebz = istebz + 1
!!$ if (istebz == 1) then
!!$ td(istebz) = done/alpha
!!$ else
!!$ td(istebz) = done/alpha + beta/alpha_old
!!$ tu(istebz-1) = sqrt(beta)/alpha_old
!!$ end if
!!$ end if
!!$
!!$ call psb_geaxpby(alpha,p,done,x,desc_a,info)
!!$ call psb_geaxpby(-alpha,q,done,r,desc_a,info)
!!$
!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ end do iteration
!!$ end do restart
!!$
!!$ if (do_cond) then
!!$ if (me == 0) then
!!$#if defined(HAVE_LAPACK)
!!$ call dstebz('A','E',istebz,dzero,dzero,0,0,-done,td,tu,&
!!$ & ieg,nspl,eig,ibl,ispl,ewrk,iwrk,info)
!!$ if (info < 0) then
!!$ call psb_errpush(psb_err_from_subroutine_ai_,name,a_err='dstebz',i_err=(/info,0,0,0,0/))
!!$ info = psb_err_from_subroutine_ai_
!!$ goto 9999
!!$ end if
!!$ cond = eig(ieg)/eig(1)
!!$#else
!!$ cond = -1.0
!!$#endif
!!$ info = psb_success_
!!$ end if
!!$ call psb_bcast(ictxt,cond,root=0)
!!$ end if
!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter)
!!$
!!$ call psb_gefree(wwrk,desc_a,info)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ ! restore external global coherence behaviour
!!$ call psb_restore_coher(ictxt,isvch)
!!$
!!$ 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_dcg
subroutine psb_dcg_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop,cond)
krylov/psb_dcgs.f90
+226 -226
View File
@@ -94,233 +94,233 @@
! estimate of) residual.
!
!
Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod
use psb_prec_mod
use psb_d_inner_krylov_mod
use psb_krylov_mod
implicit none
type(psb_dspmat_type), intent(in) :: a
class(psb_dprec_type), Intent(in) :: prec
Type(psb_desc_type), Intent(in) :: desc_a
Real(psb_dpk_), Intent(in) :: b(:)
Real(psb_dpk_), Intent(inout) :: x(:)
Real(psb_dpk_), Intent(in) :: eps
integer, intent(out) :: info
Integer, Optional, Intent(in) :: itmax, itrace,istop
Integer, Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
!!$ local data
Real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:)
Real(psb_dpk_), Pointer :: ww(:), q(:),&
& r(:), p(:), v(:), s(:), z(:), f(:), rt(:),qt(:),uv(:)
Integer :: itmax_, naux, mglob, it, itrace_,int_err(5),&
& np,me, n_row, n_col,istop_, err_act
Integer :: itx, isvch, ictxt
integer :: debug_level, debug_unit
Real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma
type(psb_itconv_type) :: stopdat
character(len=20) :: name
character(len=*), parameter :: methdname='CGS'
info = psb_success_
name = 'psb_dcgs'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
Call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),': from psb_info',np
mglob = desc_a%get_global_rows()
n_row = desc_a%get_local_rows()
n_col = desc_a%get_local_cols()
If (Present(istop)) Then
istop_ = istop
Else
istop_ = 2
Endif
call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_chkvect on X/B')
goto 9999
end if
naux=4*n_col
Allocate(aux(naux),stat=info)
if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11)
if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info)
if (info /= psb_success_) Then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
End If
q => wwrk(:,1)
qt => wwrk(:,2)
r => wwrk(:,3)
rt => wwrk(:,4)
p => wwrk(:,5)
v => wwrk(:,6)
uv => wwrk(:,7)
z => wwrk(:,8)
f => wwrk(:,9)
s => wwrk(:,10)
ww => wwrk(:,11)
If (Present(itmax)) Then
itmax_ = itmax
Else
itmax_ = 1000
Endif
If (Present(itrace)) Then
itrace_ = itrace
Else
itrace_ = 0
End If
! Ensure global coherence for convergence checks.
call psb_set_coher(ictxt,isvch)
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
restart: Do
!!$Subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
!!$ use psb_base_mod
!!$ use psb_prec_mod
!!$ use psb_d_inner_krylov_mod
!!$ use psb_krylov_mod
!!$ implicit none
!!$ type(psb_dspmat_type), intent(in) :: a
!!$ class(psb_dprec_type), Intent(in) :: prec
!!$ Type(psb_desc_type), Intent(in) :: desc_a
!!$ Real(psb_dpk_), Intent(in) :: b(:)
!!$ Real(psb_dpk_), Intent(inout) :: x(:)
!!$ Real(psb_dpk_), Intent(in) :: eps
!!$ integer, intent(out) :: info
!!$ Integer, Optional, Intent(in) :: itmax, itrace,istop
!!$ Integer, Optional, Intent(out) :: iter
!!$ Real(psb_dpk_), Optional, Intent(out) :: err
!!$! !$ local data
!!$ Real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:)
!!$ Real(psb_dpk_), Pointer :: ww(:), q(:),&
!!$ & r(:), p(:), v(:), s(:), z(:), f(:), rt(:),qt(:),uv(:)
!!$ Integer :: itmax_, naux, mglob, it, itrace_,int_err(5),&
!!$ & np,me, n_row, n_col,istop_, err_act
!!$ Integer :: itx, isvch, ictxt
!!$ integer :: debug_level, debug_unit
!!$ Real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma
!!$ type(psb_itconv_type) :: stopdat
!!$ character(len=20) :: name
!!$ character(len=*), parameter :: methdname='CGS'
!!$
!!$ r0 = b-ax0
!!$
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
rho = dzero
iteration: do
it = it + 1
itx = itx + 1
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),'iteration: ',itx
rho_old = rho
rho = psb_gedot(rt,r,desc_a,info)
if (rho == dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' iteration breakdown r',rho
exit iteration
endif
if (it == 1) then
call psb_geaxpby(done,r,dzero,uv,desc_a,info)
if (info == psb_success_) call psb_geaxpby(done,r,dzero,p,desc_a,info)
else
beta = (rho/rho_old)
call psb_geaxpby(done,r,dzero,uv,desc_a,info)
if (info == psb_success_) call psb_geaxpby(beta,q,done,uv,desc_a,info)
if (info == psb_success_) call psb_geaxpby(done,q,beta,p,desc_a,info)
if (info == psb_success_) call psb_geaxpby(done,uv,beta,p,desc_a,info)
end if
if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux)
if (info == psb_success_) call psb_spmm(done,a,f,dzero,v,desc_a,info,&
& work=aux)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ')
goto 9999
end if
sigma = psb_gedot(rt,v,desc_a,info)
if (sigma == dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' iteration breakdown s1', sigma
exit iteration
endif
alpha = rho/sigma
if (info == psb_success_) call psb_geaxpby(done,uv,dzero,q,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-alpha,v,done,q,desc_a,info)
if (info == psb_success_) call psb_geaxpby(done,uv,dzero,s,desc_a,info)
if (info == psb_success_) call psb_geaxpby(done,q,done,s,desc_a,info)
if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux)
if (info == psb_success_) call psb_geaxpby(alpha,z,done,x,desc_a,info)
if (info == psb_success_) call psb_spmm(done,a,z,dzero,qt,desc_a,info,&
& work=aux)
if (info == psb_success_) call psb_geaxpby(-alpha,qt,done,r,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ')
goto 9999
end if
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
end do iteration
end do restart
call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter)
deallocate(aux,stat=info)
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
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_dcgs
!!$ info = psb_success_
!!$ name = 'psb_dcgs'
!!$ call psb_erractionsave(err_act)
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$
!!$ ictxt = desc_a%get_context()
!!$ Call psb_info(ictxt, me, np)
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np
!!$
!!$ mglob = desc_a%get_global_rows()
!!$ n_row = desc_a%get_local_rows()
!!$ n_col = desc_a%get_local_cols()
!!$
!!$ If (Present(istop)) Then
!!$ istop_ = istop
!!$ Else
!!$ istop_ = 2
!!$ Endif
!!$
!!$ call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
!!$ if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B')
!!$ goto 9999
!!$ end if
!!$
!!$ naux=4*n_col
!!$ Allocate(aux(naux),stat=info)
!!$ if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=11)
!!$ if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info)
!!$ if (info /= psb_success_) Then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ End If
!!$
!!$ q => wwrk(:,1)
!!$ qt => wwrk(:,2)
!!$ r => wwrk(:,3)
!!$ rt => wwrk(:,4)
!!$ p => wwrk(:,5)
!!$ v => wwrk(:,6)
!!$ uv => wwrk(:,7)
!!$ z => wwrk(:,8)
!!$ f => wwrk(:,9)
!!$ s => wwrk(:,10)
!!$ ww => wwrk(:,11)
!!$
!!$
!!$ If (Present(itmax)) Then
!!$ itmax_ = itmax
!!$ Else
!!$ itmax_ = 1000
!!$ Endif
!!$
!!$ If (Present(itrace)) Then
!!$ itrace_ = itrace
!!$ Else
!!$ itrace_ = 0
!!$ End If
!!$
!!$ ! Ensure global coherence for convergence checks.
!!$ call psb_set_coher(ictxt,isvch)
!!$
!!$ itx = 0
!!$
!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info)
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ restart: Do
!!$! !$
!!$! !$ r0 = b-ax0
!!$! !$
!!$ if (itx >= itmax_) exit restart
!!$ it = 0
!!$ call psb_geaxpby(done,b,dzero,r,desc_a,info)
!!$ if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt,desc_a,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$
!!$ ! Perhaps we already satisfy the convergence criterion...
!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ rho = dzero
!!$
!!$ iteration: do
!!$ it = it + 1
!!$ itx = itx + 1
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),'iteration: ',itx
!!$
!!$ rho_old = rho
!!$ rho = psb_gedot(rt,r,desc_a,info)
!!$
!!$ if (rho == dzero) then
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' iteration breakdown r',rho
!!$ exit iteration
!!$ endif
!!$
!!$ if (it == 1) then
!!$ call psb_geaxpby(done,r,dzero,uv,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,p,desc_a,info)
!!$ else
!!$ beta = (rho/rho_old)
!!$ call psb_geaxpby(done,r,dzero,uv,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(beta,q,done,uv,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(done,q,beta,p,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(done,uv,beta,p,desc_a,info)
!!$ end if
!!$
!!$ if (info == psb_success_) call prec%apply(p,f,desc_a,info,work=aux)
!!$
!!$ if (info == psb_success_) call psb_spmm(done,a,f,dzero,v,desc_a,info,&
!!$ & work=aux)
!!$
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='First loop part ')
!!$ goto 9999
!!$ end if
!!$
!!$ sigma = psb_gedot(rt,v,desc_a,info)
!!$ if (sigma == dzero) then
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' iteration breakdown s1', sigma
!!$ exit iteration
!!$ endif
!!$
!!$ alpha = rho/sigma
!!$
!!$ if (info == psb_success_) call psb_geaxpby(done,uv,dzero,q,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(-alpha,v,done,q,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(done,uv,dzero,s,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(done,q,done,s,desc_a,info)
!!$
!!$ if (info == psb_success_) call prec%apply(s,z,desc_a,info,work=aux)
!!$
!!$ if (info == psb_success_) call psb_geaxpby(alpha,z,done,x,desc_a,info)
!!$
!!$ if (info == psb_success_) call psb_spmm(done,a,z,dzero,qt,desc_a,info,&
!!$ & work=aux)
!!$
!!$ if (info == psb_success_) call psb_geaxpby(-alpha,qt,done,r,desc_a,info)
!!$
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='X update ')
!!$ goto 9999
!!$ end if
!!$
!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ end do iteration
!!$ end do restart
!!$
!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter)
!!$
!!$ deallocate(aux,stat=info)
!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ ! restore external global coherence behaviour
!!$ call psb_restore_coher(ictxt,isvch)
!!$ 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_dcgs
Subroutine psb_dcgs_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,istop)
krylov/psb_dcgstab.F90
+328 -328
View File
@@ -94,334 +94,334 @@
!
!
!
Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod
use psb_prec_mod
use psb_d_inner_krylov_mod
use psb_krylov_mod
implicit none
type(psb_dspmat_type), intent(in) :: a
class(psb_dprec_type), Intent(in) :: prec
Type(psb_desc_type), Intent(in) :: desc_a
Real(psb_dpk_), Intent(in) :: b(:)
Real(psb_dpk_), Intent(inout) :: x(:)
Real(psb_dpk_), Intent(in) :: eps
integer, intent(out) :: info
Integer, Optional, Intent(in) :: itmax, itrace, istop
Integer, Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
!!$ Local data
Real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:)
Real(psb_dpk_), Pointer :: q(:),&
& r(:), p(:), v(:), s(:), t(:), z(:), f(:)
Integer :: itmax_, naux, mglob, it,itrace_,&
& np,me, n_row, n_col
integer :: debug_level, debug_unit
Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False.
Integer, Parameter :: irmax = 8
Integer :: itx, isvch, ictxt, err_act, i
Integer :: istop_
Real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma, omega, tau
type(psb_itconv_type) :: stopdat
#ifdef MPE_KRYLOV
include "mpe_logf.h"
Integer istpb, istpe, ifctb, ifcte, imerr, irank, icomm,immb,imme
#endif
character(len=20) :: name
character(len=*), parameter :: methdname='BiCGStab'
info = psb_success_
name = 'psb_dcgstab'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),': from psb_info',np
#ifdef MPE_KRYLOV
!!$ call psb_get_mpicomm(ictxt,icomm)
!!$ call psb_get_rank(irank,icomm,me)
imerr = MPE_Log_get_state_eventIDs(istpb,istpe)
imerr = MPE_Log_get_state_eventIDs(ifctb,ifcte)
imerr = MPE_Log_get_state_eventIDs(immb,imme)
if (me == 0) then
info = mpe_describe_state(istpb,istpe,"Solver","WhiteSmoke")
info = mpe_describe_state(ifctb,ifcte,"PREC","SteelBlue")
info = mpe_describe_state(immb,imme,"SPMM","DarkOrange")
endif
call psb_barrier(ictxt)
call mpi_Pcontrol(1,info)
#endif
mglob = desc_a%get_global_rows()
n_row = desc_a%get_local_rows()
n_col = desc_a%get_local_cols()
If (Present(istop)) Then
istop_ = istop
Else
istop_ = 2
Endif
!
! ISTOP_ = 1: Normwise backward error, infinity norm
! ISTOP_ = 2: ||r||/||b|| norm 2
!
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( istpb, 0, "st CGSTAB" )
#endif
call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_chkvect on X')
goto 9999
end if
call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_chkvect on B')
goto 9999
end if
naux=6*n_col
allocate(aux(naux),stat=info)
if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=8)
if (info == psb_success_) call psb_geasb(wwrk,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
End If
Q => WWRK(:,1)
R => WWRK(:,2)
P => WWRK(:,3)
V => WWRK(:,4)
F => WWRK(:,5)
S => WWRK(:,6)
T => WWRK(:,7)
Z => WWRK(:,8)
If (Present(itmax)) Then
itmax_ = itmax
Else
itmax_ = 1000
Endif
If (Present(itrace)) Then
itrace_ = itrace
Else
itrace_ = 0
End If
! Ensure global coherence for convergence checks.
call psb_set_coher(ictxt,isvch)
itx = 0
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info)
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
restart: Do
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( immb, 0, "st SPMM" )
#endif
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( imme, 0, "ed SPMM" )
#endif
if (info == psb_success_) call psb_geaxpby(done,r,dzero,q,desc_a,info)
if (psb_errstatus_fatal()) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='Init residual')
goto 9999
end if
! Perhaps we already satisfy the convergence criterion...
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
rho = dzero
iteration: Do
it = it + 1
itx = itx + 1
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),&
& ' Iteration: ',itx
rho_old = rho
rho = psb_gedot(q,r,desc_a,info)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),&
& ' Rho: ',rho
if (rho == dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown R',rho
exit iteration
endif
if (it == 1) then
call psb_geaxpby(done,r,dzero,p,desc_a,info)
else
beta = (rho/rho_old)*(alpha/omega)
call psb_geaxpby(-omega,v,done,p,desc_a,info)
call psb_geaxpby(done,r,beta,p,desc_a,info)
End If
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( ifctb, 0, "st PREC" )
#endif
if (debug_level >= psb_debug_inner_) write(0,*) 'P: ',p
call prec%apply(p,f,desc_a,info,work=aux)
if (debug_level >= psb_debug_inner_) write(0,*) 'F: ',f
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( ifcte, 0, "ed PREC" )
imerr = MPE_Log_event( immb, 0, "st SPMM" )
#endif
call psb_spmm(done,a,f,dzero,v,desc_a,info,&
& work=aux)
if (debug_level >= psb_debug_inner_) write(0,*) 'Q: ',q
if (debug_level >= psb_debug_inner_) write(0,*) 'V: ',v
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( imme, 0, "ed SPMM" )
#endif
sigma = psb_gedot(q,v,desc_a,info)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),&
& ' Sigma: ',sigma
if (sigma == dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown S1', sigma
exit iteration
endif
alpha = rho/sigma
call psb_geaxpby(done,r,dzero,s,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-alpha,v,done,s,desc_a,info)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),&
& ' alpha: ',alpha
if(psb_errstatus_fatal()) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_geaxpby')
goto 9999
end if
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( ifctb, 0, "st PREC" )
#endif
call prec%apply(s,z,desc_a,info,work=aux)
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( ifcte, 0, "ed PREC" )
imerr = MPE_Log_event( immb, 0, "st SPMM" )
#endif
if (info == psb_success_) Call psb_spmm(done,a,z,dzero,t,desc_a,info,&
& work=aux)
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( imme, 0, "ed SPMM" )
#endif
if(psb_errstatus_fatal()) then
call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm')
goto 9999
end if
sigma = psb_gedot(t,t,desc_a,info)
if (sigma == dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown S2', sigma
exit iteration
endif
tau = psb_gedot(t,s,desc_a,info)
omega = tau/sigma
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),&
& ' sigma, tau, omega: ',sigma, tau, omega
if (omega == dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Iteration breakdown O',omega
exit iteration
endif
call psb_geaxpby(alpha,f,done,x,desc_a,info)
if (info == psb_success_) call psb_geaxpby(omega,z,done,x,desc_a,info)
if (info == psb_success_) call psb_geaxpby(done,s,dzero,r,desc_a,info)
if (info == psb_success_) call psb_geaxpby(-omega,t,done,r,desc_a,info)
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_,name,a_err='X/R update ')
goto 9999
End If
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (psb_errstatus_fatal()) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
end do iteration
end do restart
call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter)
deallocate(aux,stat=info)
call psb_gefree(wwrk,desc_a,info)
if((info /= 0).or.(psb_errstatus_fatal())) then
call psb_errpush(info,name)
goto 9999
end if
#ifdef MPE_KRYLOV
imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" )
call mpi_Pcontrol(2,info)
call mpi_Pcontrol(0,info)
#endif
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
call psb_erractionrestore(err_act)
return
9999 continue
call psb_erractionrestore(err_act)
if (err_act == psb_act_abort_) then
call psb_error(ictxt)
return
end if
return
End Subroutine psb_dcgstab
!!$Subroutine psb_dcgstab(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
!!$ use psb_base_mod
!!$ use psb_prec_mod
!!$ use psb_d_inner_krylov_mod
!!$ use psb_krylov_mod
!!$ implicit none
!!$
!!$ type(psb_dspmat_type), intent(in) :: a
!!$ class(psb_dprec_type), Intent(in) :: prec
!!$ Type(psb_desc_type), Intent(in) :: desc_a
!!$ Real(psb_dpk_), Intent(in) :: b(:)
!!$ Real(psb_dpk_), Intent(inout) :: x(:)
!!$ Real(psb_dpk_), Intent(in) :: eps
!!$ integer, intent(out) :: info
!!$ Integer, Optional, Intent(in) :: itmax, itrace, istop
!!$ Integer, Optional, Intent(out) :: iter
!!$ Real(psb_dpk_), Optional, Intent(out) :: err
!!$! !$ Local data
!!$ Real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:)
!!$ Real(psb_dpk_), Pointer :: q(:),&
!!$ & r(:), p(:), v(:), s(:), t(:), z(:), f(:)
!!$ Integer :: itmax_, naux, mglob, it,itrace_,&
!!$ & np,me, n_row, n_col
!!$ integer :: debug_level, debug_unit
!!$ Logical, Parameter :: exchange=.True., noexchange=.False., debug1 = .False.
!!$ Integer, Parameter :: irmax = 8
!!$ Integer :: itx, isvch, ictxt, err_act, i
!!$ Integer :: istop_
!!$ Real(psb_dpk_) :: alpha, beta, rho, rho_old, sigma, omega, tau
!!$ type(psb_itconv_type) :: stopdat
!!$
!!$#ifdef MPE_KRYLOV
!!$ include "mpe_logf.h"
!!$ Integer istpb, istpe, ifctb, ifcte, imerr, irank, icomm,immb,imme
!!$#endif
!!$ character(len=20) :: name
!!$ character(len=*), parameter :: methdname='BiCGStab'
!!$
!!$ info = psb_success_
!!$ name = 'psb_dcgstab'
!!$ call psb_erractionsave(err_act)
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$ ictxt = desc_a%get_context()
!!$ call psb_info(ictxt, me, np)
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np
!!$
!!$#ifdef MPE_KRYLOV
!!$! !$ call psb_get_mpicomm(ictxt,icomm)
!!$! !$ call psb_get_rank(irank,icomm,me)
!!$ imerr = MPE_Log_get_state_eventIDs(istpb,istpe)
!!$ imerr = MPE_Log_get_state_eventIDs(ifctb,ifcte)
!!$ imerr = MPE_Log_get_state_eventIDs(immb,imme)
!!$
!!$ if (me == 0) then
!!$ info = mpe_describe_state(istpb,istpe,"Solver","WhiteSmoke")
!!$ info = mpe_describe_state(ifctb,ifcte,"PREC","SteelBlue")
!!$ info = mpe_describe_state(immb,imme,"SPMM","DarkOrange")
!!$ endif
!!$ call psb_barrier(ictxt)
!!$ call mpi_Pcontrol(1,info)
!!$#endif
!!$
!!$ mglob = desc_a%get_global_rows()
!!$ n_row = desc_a%get_local_rows()
!!$ n_col = desc_a%get_local_cols()
!!$
!!$ If (Present(istop)) Then
!!$ istop_ = istop
!!$ Else
!!$ istop_ = 2
!!$ Endif
!!$ !
!!$ ! ISTOP_ = 1: Normwise backward error, infinity norm
!!$ ! ISTOP_ = 2: ||r||/||b|| norm 2
!!$ !
!!$
!!$#ifdef MPE_KRYLOV
!!$ imerr = MPE_Log_event( istpb, 0, "st CGSTAB" )
!!$#endif
!!$
!!$
!!$ call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_chkvect on X')
!!$ goto 9999
!!$ end if
!!$ call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_chkvect on B')
!!$ goto 9999
!!$ end if
!!$
!!$ naux=6*n_col
!!$ allocate(aux(naux),stat=info)
!!$ if (info == psb_success_) call psb_geall(wwrk,desc_a,info,n=8)
!!$ if (info == psb_success_) call psb_geasb(wwrk,desc_a,info)
!!$
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ End If
!!$
!!$ Q => WWRK(:,1)
!!$ R => WWRK(:,2)
!!$ P => WWRK(:,3)
!!$ V => WWRK(:,4)
!!$ F => WWRK(:,5)
!!$ S => WWRK(:,6)
!!$ T => WWRK(:,7)
!!$ Z => WWRK(:,8)
!!$
!!$ If (Present(itmax)) Then
!!$ itmax_ = itmax
!!$ Else
!!$ itmax_ = 1000
!!$ Endif
!!$
!!$ If (Present(itrace)) Then
!!$ itrace_ = itrace
!!$ Else
!!$ itrace_ = 0
!!$ End If
!!$
!!$ ! Ensure global coherence for convergence checks.
!!$ call psb_set_coher(ictxt,isvch)
!!$
!!$ itx = 0
!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info)
!!$ if (psb_errstatus_fatal()) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ restart: Do
!!$
!!$ if (itx >= itmax_) exit restart
!!$
!!$ it = 0
!!$ call psb_geaxpby(done,b,dzero,r,desc_a,info)
!!$#ifdef MPE_KRYLOV
!!$ imerr = MPE_Log_event( immb, 0, "st SPMM" )
!!$#endif
!!$ if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
!!$#ifdef MPE_KRYLOV
!!$ imerr = MPE_Log_event( imme, 0, "ed SPMM" )
!!$#endif
!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,q,desc_a,info)
!!$ if (psb_errstatus_fatal()) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='Init residual')
!!$ goto 9999
!!$ end if
!!$
!!$ ! Perhaps we already satisfy the convergence criterion...
!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
!!$ if (psb_errstatus_fatal()) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ rho = dzero
!!$
!!$ iteration: Do
!!$ it = it + 1
!!$ itx = itx + 1
!!$
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Iteration: ',itx
!!$
!!$ rho_old = rho
!!$ rho = psb_gedot(q,r,desc_a,info)
!!$
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Rho: ',rho
!!$
!!$ if (rho == dzero) then
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Iteration breakdown R',rho
!!$ exit iteration
!!$ endif
!!$
!!$ if (it == 1) then
!!$ call psb_geaxpby(done,r,dzero,p,desc_a,info)
!!$ else
!!$ beta = (rho/rho_old)*(alpha/omega)
!!$ call psb_geaxpby(-omega,v,done,p,desc_a,info)
!!$ call psb_geaxpby(done,r,beta,p,desc_a,info)
!!$ End If
!!$
!!$#ifdef MPE_KRYLOV
!!$ imerr = MPE_Log_event( ifctb, 0, "st PREC" )
!!$#endif
!!$ if (debug_level >= psb_debug_inner_) write(0,*) 'P: ',p
!!$ call prec%apply(p,f,desc_a,info,work=aux)
!!$ if (debug_level >= psb_debug_inner_) write(0,*) 'F: ',f
!!$#ifdef MPE_KRYLOV
!!$ imerr = MPE_Log_event( ifcte, 0, "ed PREC" )
!!$ imerr = MPE_Log_event( immb, 0, "st SPMM" )
!!$#endif
!!$ call psb_spmm(done,a,f,dzero,v,desc_a,info,&
!!$ & work=aux)
!!$ if (debug_level >= psb_debug_inner_) write(0,*) 'Q: ',q
!!$ if (debug_level >= psb_debug_inner_) write(0,*) 'V: ',v
!!$
!!$#ifdef MPE_KRYLOV
!!$ imerr = MPE_Log_event( imme, 0, "ed SPMM" )
!!$#endif
!!$
!!$ sigma = psb_gedot(q,v,desc_a,info)
!!$
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Sigma: ',sigma
!!$ if (sigma == dzero) then
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Iteration breakdown S1', sigma
!!$ exit iteration
!!$ endif
!!$
!!$ alpha = rho/sigma
!!$ call psb_geaxpby(done,r,dzero,s,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(-alpha,v,done,s,desc_a,info)
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' alpha: ',alpha
!!$
!!$ if(psb_errstatus_fatal()) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='psb_geaxpby')
!!$ goto 9999
!!$ end if
!!$
!!$#ifdef MPE_KRYLOV
!!$ imerr = MPE_Log_event( ifctb, 0, "st PREC" )
!!$#endif
!!$ call prec%apply(s,z,desc_a,info,work=aux)
!!$
!!$#ifdef MPE_KRYLOV
!!$ imerr = MPE_Log_event( ifcte, 0, "ed PREC" )
!!$ imerr = MPE_Log_event( immb, 0, "st SPMM" )
!!$#endif
!!$ if (info == psb_success_) Call psb_spmm(done,a,z,dzero,t,desc_a,info,&
!!$ & work=aux)
!!$
!!$#ifdef MPE_KRYLOV
!!$ imerr = MPE_Log_event( imme, 0, "ed SPMM" )
!!$#endif
!!$ if(psb_errstatus_fatal()) then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='precaply/spmm')
!!$ goto 9999
!!$ end if
!!$
!!$ sigma = psb_gedot(t,t,desc_a,info)
!!$ if (sigma == dzero) then
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Iteration breakdown S2', sigma
!!$ exit iteration
!!$ endif
!!$
!!$ tau = psb_gedot(t,s,desc_a,info)
!!$ omega = tau/sigma
!!$
!!$
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' sigma, tau, omega: ',sigma, tau, omega
!!$ if (omega == dzero) then
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Iteration breakdown O',omega
!!$ exit iteration
!!$ endif
!!$
!!$ call psb_geaxpby(alpha,f,done,x,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(omega,z,done,x,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(done,s,dzero,r,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(-omega,t,done,r,desc_a,info)
!!$ if (psb_errstatus_fatal()) Then
!!$ call psb_errpush(psb_err_from_subroutine_,name,a_err='X/R update ')
!!$ goto 9999
!!$ End If
!!$
!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
!!$ if (psb_errstatus_fatal()) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ end do iteration
!!$ end do restart
!!$
!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter)
!!$
!!$ deallocate(aux,stat=info)
!!$ call psb_gefree(wwrk,desc_a,info)
!!$ if((info /= 0).or.(psb_errstatus_fatal())) then
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$#ifdef MPE_KRYLOV
!!$ imerr = MPE_Log_event( istpe, 0, "ed CGSTAB" )
!!$ call mpi_Pcontrol(2,info)
!!$ call mpi_Pcontrol(0,info)
!!$#endif
!!$ ! restore external global coherence behaviour
!!$ call psb_restore_coher(ictxt,isvch)
!!$
!!$ call psb_erractionrestore(err_act)
!!$ return
!!$
!!$9999 continue
!!$ call psb_erractionrestore(err_act)
!!$ if (err_act == psb_act_abort_) then
!!$ call psb_error(ictxt)
!!$ return
!!$ end if
!!$ return
!!$
!!$End Subroutine psb_dcgstab
Subroutine psb_dcgstab_vect(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,istop)
krylov/psb_dcgstabl.f90
+302 -302
View File
@@ -103,309 +103,309 @@
!
!
!
Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop)
use psb_base_mod
use psb_prec_mod
use psb_d_inner_krylov_mod
use psb_krylov_mod
implicit none
type(psb_dspmat_type), intent(in) :: a
class(psb_dprec_type), Intent(in) :: prec
Type(psb_desc_type), Intent(in) :: desc_a
Real(psb_dpk_), Intent(in) :: b(:)
Real(psb_dpk_), Intent(inout) :: x(:)
Real(psb_dpk_), Intent(in) :: eps
integer, intent(out) :: info
Integer, Optional, Intent(in) :: itmax, itrace, irst,istop
Integer, Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
!!$ local data
Real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:),uh(:,:), rh(:,:),&
& gamma(:), gamma1(:), gamma2(:), taum(:,:), sigma(:)
Real(psb_dpk_), Pointer :: ww(:), q(:), r(:), rt0(:), p(:), v(:), &
& s(:), t(:), z(:), f(:)
Integer :: itmax_, naux, mglob, it, itrace_,&
& np,me, n_row, n_col, nl, err_act
Logical, Parameter :: exchange=.True., noexchange=.False.
Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ictxt,istop_,j, int_err(5)
integer :: debug_level, debug_unit
Real(psb_dpk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,&
& omega
type(psb_itconv_type) :: stopdat
character(len=20) :: name
character(len=*), parameter :: methdname='BiCGStab(L)'
info = psb_success_
name = 'psb_dcgstabl'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
Call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),': from psb_info',np
mglob = desc_a%get_global_rows()
n_row = desc_a%get_local_rows()
n_col = desc_a%get_local_cols()
if (present(istop)) then
istop_ = istop
else
istop_ = 2
endif
if (present(itmax)) then
itmax_ = itmax
else
itmax_ = 1000
endif
if (present(itrace)) then
itrace_ = itrace
else
itrace_ = 0
end if
if (present(irst)) then
nl = irst
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& 'present: irst: ',irst,nl
else
nl = 1
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' not present: irst: ',irst,nl
endif
if (nl <=0 ) then
info=psb_err_invalid_istop_
int_err(1)=nl
err=info
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_chkvect on X/B')
goto 9999
end if
naux=4*n_col
allocate(aux(naux),gamma(0:nl),gamma1(nl),&
&gamma2(nl),taum(nl,nl),sigma(nl), stat=info)
if (info /= psb_success_) then
info=psb_err_alloc_dealloc_
call psb_errpush(info,name)
goto 9999
end if
if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=10)
if (info == psb_success_) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0)
if (info == psb_success_) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0)
if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info)
if (info == psb_success_) Call psb_geasb(uh,desc_a,info)
if (info == psb_success_) Call psb_geasb(rh,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
q => wwrk(:,1)
r => wwrk(:,2)
p => wwrk(:,3)
v => wwrk(:,4)
f => wwrk(:,5)
s => wwrk(:,6)
t => wwrk(:,7)
z => wwrk(:,8)
ww => wwrk(:,9)
rt0 => wwrk(:,10)
! Ensure global coherence for convergence checks.
call psb_set_coher(ictxt,isvch)
call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info)
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
itx = 0
restart: do
!!$Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop)
!!$ use psb_base_mod
!!$ use psb_prec_mod
!!$ use psb_d_inner_krylov_mod
!!$ use psb_krylov_mod
!!$ implicit none
!!$ type(psb_dspmat_type), intent(in) :: a
!!$
!!$
!!$ class(psb_dprec_type), Intent(in) :: prec
!!$ Type(psb_desc_type), Intent(in) :: desc_a
!!$ Real(psb_dpk_), Intent(in) :: b(:)
!!$ Real(psb_dpk_), Intent(inout) :: x(:)
!!$ Real(psb_dpk_), Intent(in) :: eps
!!$ integer, intent(out) :: info
!!$ Integer, Optional, Intent(in) :: itmax, itrace, irst,istop
!!$ Integer, Optional, Intent(out) :: iter
!!$ Real(psb_dpk_), Optional, Intent(out) :: err
!!$! !$ local data
!!$ Real(psb_dpk_), allocatable, target :: aux(:),wwrk(:,:),uh(:,:), rh(:,:),&
!!$ & gamma(:), gamma1(:), gamma2(:), taum(:,:), sigma(:)
!!$ Real(psb_dpk_), Pointer :: ww(:), q(:), r(:), rt0(:), p(:), v(:), &
!!$ & s(:), t(:), z(:), f(:)
!!$
!!$ Integer :: itmax_, naux, mglob, it, itrace_,&
!!$ & np,me, n_row, n_col, nl, err_act
!!$ Logical, Parameter :: exchange=.True., noexchange=.False.
!!$ Integer, Parameter :: irmax = 8
!!$ Integer :: itx, i, isvch, ictxt,istop_,j, int_err(5)
!!$ integer :: debug_level, debug_unit
!!$ Real(psb_dpk_) :: alpha, beta, rho, rho_old, rni, xni, bni, ani,bn2,&
!!$ & omega
!!$ type(psb_itconv_type) :: stopdat
!!$ character(len=20) :: name
!!$ character(len=*), parameter :: methdname='BiCGStab(L)'
!!$
!!$ info = psb_success_
!!$ name = 'psb_dcgstabl'
!!$ call psb_erractionsave(err_act)
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$
!!$ ictxt = desc_a%get_context()
!!$ Call psb_info(ictxt, me, np)
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np
!!$
!!$
!!$ mglob = desc_a%get_global_rows()
!!$ n_row = desc_a%get_local_rows()
!!$ n_col = desc_a%get_local_cols()
!!$
!!$ if (present(istop)) then
!!$ istop_ = istop
!!$ else
!!$ istop_ = 2
!!$ endif
!!$
!!$ if (present(itmax)) then
!!$ itmax_ = itmax
!!$ else
!!$ itmax_ = 1000
!!$ endif
!!$
!!$ if (present(itrace)) then
!!$ itrace_ = itrace
!!$ else
!!$ itrace_ = 0
!!$ end if
!!$
!!$ if (present(irst)) then
!!$ nl = irst
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & 'present: irst: ',irst,nl
!!$ else
!!$ nl = 1
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' not present: irst: ',irst,nl
!!$ endif
!!$ if (nl <=0 ) then
!!$ info=psb_err_invalid_istop_
!!$ int_err(1)=nl
!!$ err=info
!!$ call psb_errpush(info,name,i_err=int_err)
!!$ goto 9999
!!$ endif
!!$
!!$ call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
!!$ if (info == psb_success_) call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_chkvect on X/B')
!!$ goto 9999
!!$ end if
!!$
!!$ naux=4*n_col
!!$ allocate(aux(naux),gamma(0:nl),gamma1(nl),&
!!$ &gamma2(nl),taum(nl,nl),sigma(nl), stat=info)
!!$
!!$ if (info /= psb_success_) then
!!$ info=psb_err_alloc_dealloc_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ if (info == psb_success_) Call psb_geall(wwrk,desc_a,info,n=10)
!!$ if (info == psb_success_) Call psb_geall(uh,desc_a,info,n=nl+1,lb=0)
!!$ if (info == psb_success_) Call psb_geall(rh,desc_a,info,n=nl+1,lb=0)
!!$ if (info == psb_success_) Call psb_geasb(wwrk,desc_a,info)
!!$ if (info == psb_success_) Call psb_geasb(uh,desc_a,info)
!!$ if (info == psb_success_) Call psb_geasb(rh,desc_a,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ q => wwrk(:,1)
!!$ r => wwrk(:,2)
!!$ p => wwrk(:,3)
!!$ v => wwrk(:,4)
!!$ f => wwrk(:,5)
!!$ s => wwrk(:,6)
!!$ t => wwrk(:,7)
!!$ z => wwrk(:,8)
!!$ ww => wwrk(:,9)
!!$ rt0 => wwrk(:,10)
!!$
!!$ ! Ensure global coherence for convergence checks.
!!$ call psb_set_coher(ictxt,isvch)
!!$
!!$
!!$ call psb_init_conv(methdname,istop_,itrace_,itmax_,a,b,eps,desc_a,stopdat,info)
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ itx = 0
!!$ restart: do
!!$! !$
!!$! !$ r0 = b-ax0
!!$! !$
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),' restart: ',itx,it
!!$ if (itx >= itmax_) exit restart
!!$
!!$ it = 0
!!$ call psb_geaxpby(done,b,dzero,r,desc_a,info)
!!$ if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
!!$
!!$ if (info == psb_success_) call prec%apply(r,desc_a,info)
!!$
!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt0,desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(done,r,dzero,rh(:,0),desc_a,info)
!!$ if (info == psb_success_) call psb_geaxpby(dzero,r,dzero,uh(:,0),desc_a,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ r0 = b-ax0
!!$
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),' restart: ',itx,it
if (itx >= itmax_) exit restart
it = 0
call psb_geaxpby(done,b,dzero,r,desc_a,info)
if (info == psb_success_) call psb_spmm(-done,a,x,done,r,desc_a,info,work=aux)
if (info == psb_success_) call prec%apply(r,desc_a,info)
if (info == psb_success_) call psb_geaxpby(done,r,dzero,rt0,desc_a,info)
if (info == psb_success_) call psb_geaxpby(done,r,dzero,rh(:,0),desc_a,info)
if (info == psb_success_) call psb_geaxpby(dzero,r,dzero,uh(:,0),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
rho = done
alpha = dzero
omega = done
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' on entry to amax: b: ',Size(b)
if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
iteration: do
it = it + nl
itx = itx + nl
rho = -omega*rho
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' iteration: ',itx, rho,rh(1,0)
do j = 0, nl -1
If (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),'bicg part: ',j, nl
rho_old = rho
rho = psb_gedot(rh(:,j),rt0,desc_a,info)
if (rho == dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' bi-cgstab iteration breakdown r',rho
exit iteration
endif
beta = alpha*rho/rho_old
rho_old = rho
call psb_geaxpby(done,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
call psb_spmm(done,a,uh(:,j),dzero,uh(:,j+1),desc_a,info,work=aux)
call prec%apply(uh(:,j+1),desc_a,info)
gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info)
if (gamma(j) == dzero) then
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' bi-cgstab iteration breakdown s2',gamma(j)
exit iteration
endif
alpha = rho/gamma(j)
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' bicg part: alpha=r/g ',alpha,rho,gamma(j)
call psb_geaxpby(-alpha,uh(:,1:j+1),done,rh(:,0:j),desc_a,info)
call psb_geaxpby(alpha,uh(:,0),done,x,desc_a,info)
call psb_spmm(done,a,rh(:,j),dzero,rh(:,j+1),desc_a,info,work=aux)
call prec%apply(rh(:,j+1),desc_a,info)
enddo
do j=1, nl
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' mod g-s part: ',j, nl,rh(1,0)
do i=1, j-1
taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info)
taum(i,j) = taum(i,j)/sigma(i)
call psb_geaxpby(-taum(i,j),rh(:,i),done,rh(:,j),desc_a,info)
enddo
sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info)
gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info)
gamma1(j) = gamma1(j)/sigma(j)
enddo
gamma(nl) = gamma1(nl)
omega = gamma(nl)
do j=nl-1,1,-1
gamma(j) = gamma1(j)
do i=j+1,nl
gamma(j) = gamma(j) - taum(j,i) * gamma(i)
enddo
enddo
do j=1,nl-1
gamma2(j) = gamma(j+1)
do i=j+1,nl-1
gamma2(j) = gamma2(j) + taum(j,i) * gamma(i+1)
enddo
enddo
call psb_geaxpby(gamma(1),rh(:,0),done,x,desc_a,info)
call psb_geaxpby(-gamma1(nl),rh(:,nl),done,rh(:,0),desc_a,info)
call psb_geaxpby(-gamma(nl),uh(:,nl),done,uh(:,0),desc_a,info)
do j=1, nl-1
call psb_geaxpby(-gamma(j),uh(:,j),done,uh(:,0),desc_a,info)
call psb_geaxpby(gamma2(j),rh(:,j),done,x,desc_a,info)
call psb_geaxpby(-gamma1(j),rh(:,j),done,rh(:,0),desc_a,info)
enddo
if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart
if (info /= psb_success_) Then
call psb_errpush(psb_err_from_subroutine_non_,name)
goto 9999
End If
end do iteration
end do restart
call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter)
deallocate(aux,stat=info)
if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
if (info == psb_success_) call psb_gefree(uh,desc_a,info)
if (info == psb_success_) call psb_gefree(rh,desc_a,info)
if (info /= psb_success_) then
call psb_errpush(info,name)
goto 9999
end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
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_dcgstabl
!!$ rho = done
!!$ alpha = dzero
!!$ omega = done
!!$
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' on entry to amax: b: ',Size(b)
!!$
!!$ if (psb_check_conv(methdname,itx,x,r,desc_a,stopdat,info)) exit restart
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ iteration: do
!!$ it = it + nl
!!$ itx = itx + nl
!!$ rho = -omega*rho
!!$
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' iteration: ',itx, rho,rh(1,0)
!!$
!!$ do j = 0, nl -1
!!$ If (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),'bicg part: ',j, nl
!!$
!!$ rho_old = rho
!!$ rho = psb_gedot(rh(:,j),rt0,desc_a,info)
!!$ if (rho == dzero) then
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' bi-cgstab iteration breakdown r',rho
!!$ exit iteration
!!$ endif
!!$
!!$ beta = alpha*rho/rho_old
!!$ rho_old = rho
!!$ call psb_geaxpby(done,rh(:,0:j),-beta,uh(:,0:j),desc_a,info)
!!$ call psb_spmm(done,a,uh(:,j),dzero,uh(:,j+1),desc_a,info,work=aux)
!!$
!!$ call prec%apply(uh(:,j+1),desc_a,info)
!!$
!!$ gamma(j) = psb_gedot(uh(:,j+1),rt0,desc_a,info)
!!$
!!$ if (gamma(j) == dzero) then
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' bi-cgstab iteration breakdown s2',gamma(j)
!!$ exit iteration
!!$ endif
!!$ alpha = rho/gamma(j)
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' bicg part: alpha=r/g ',alpha,rho,gamma(j)
!!$
!!$ call psb_geaxpby(-alpha,uh(:,1:j+1),done,rh(:,0:j),desc_a,info)
!!$ call psb_geaxpby(alpha,uh(:,0),done,x,desc_a,info)
!!$ call psb_spmm(done,a,rh(:,j),dzero,rh(:,j+1),desc_a,info,work=aux)
!!$
!!$ call prec%apply(rh(:,j+1),desc_a,info)
!!$
!!$ enddo
!!$
!!$ do j=1, nl
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' mod g-s part: ',j, nl,rh(1,0)
!!$
!!$ do i=1, j-1
!!$ taum(i,j) = psb_gedot(rh(:,i),rh(:,j),desc_a,info)
!!$ taum(i,j) = taum(i,j)/sigma(i)
!!$ call psb_geaxpby(-taum(i,j),rh(:,i),done,rh(:,j),desc_a,info)
!!$ enddo
!!$ sigma(j) = psb_gedot(rh(:,j),rh(:,j),desc_a,info)
!!$ gamma1(j) = psb_gedot(rh(:,0),rh(:,j),desc_a,info)
!!$ gamma1(j) = gamma1(j)/sigma(j)
!!$ enddo
!!$
!!$ gamma(nl) = gamma1(nl)
!!$ omega = gamma(nl)
!!$
!!$ do j=nl-1,1,-1
!!$ gamma(j) = gamma1(j)
!!$ do i=j+1,nl
!!$ gamma(j) = gamma(j) - taum(j,i) * gamma(i)
!!$ enddo
!!$ enddo
!!$
!!$ do j=1,nl-1
!!$ gamma2(j) = gamma(j+1)
!!$ do i=j+1,nl-1
!!$ gamma2(j) = gamma2(j) + taum(j,i) * gamma(i+1)
!!$ enddo
!!$ enddo
!!$
!!$ call psb_geaxpby(gamma(1),rh(:,0),done,x,desc_a,info)
!!$ call psb_geaxpby(-gamma1(nl),rh(:,nl),done,rh(:,0),desc_a,info)
!!$ call psb_geaxpby(-gamma(nl),uh(:,nl),done,uh(:,0),desc_a,info)
!!$
!!$ do j=1, nl-1
!!$ call psb_geaxpby(-gamma(j),uh(:,j),done,uh(:,0),desc_a,info)
!!$ call psb_geaxpby(gamma2(j),rh(:,j),done,x,desc_a,info)
!!$ call psb_geaxpby(-gamma1(j),rh(:,j),done,rh(:,0),desc_a,info)
!!$ enddo
!!$
!!$ if (psb_check_conv(methdname,itx,x,rh(:,0),desc_a,stopdat,info)) exit restart
!!$ if (info /= psb_success_) Then
!!$ call psb_errpush(psb_err_from_subroutine_non_,name)
!!$ goto 9999
!!$ End If
!!$
!!$ end do iteration
!!$ end do restart
!!$
!!$ call psb_end_conv(methdname,itx,desc_a,stopdat,info,err,iter)
!!$
!!$ deallocate(aux,stat=info)
!!$ if (info == psb_success_) call psb_gefree(wwrk,desc_a,info)
!!$ if (info == psb_success_) call psb_gefree(uh,desc_a,info)
!!$ if (info == psb_success_) call psb_gefree(rh,desc_a,info)
!!$ if (info /= psb_success_) then
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ ! restore external global coherence behaviour
!!$ call psb_restore_coher(ictxt,isvch)
!!$ 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_dcgstabl
Subroutine psb_dcgstabl_vect(a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop)
krylov/psb_dkrylov.f90
+165 -165
View File
@@ -77,171 +77,171 @@
! estimate of) residual
!
Subroutine psb_dkrylov(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond)
use psb_base_mod
use psb_prec_mod,only : psb_sprec_type, psb_dprec_type, psb_cprec_type, psb_zprec_type
use psb_krylov_mod, psb_protect_name => psb_dkrylov
character(len=*) :: method
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_dprec_type), intent(in) :: prec
Real(psb_dpk_), Intent(in) :: b(:)
Real(psb_dpk_), Intent(inout) :: x(:)
Real(psb_dpk_), Intent(in) :: eps
integer, intent(out) :: info
Integer, Optional, Intent(in) :: itmax, itrace, irst,istop
Integer, Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err,cond
interface
subroutine psb_dcg(a,prec,b,x,eps,&
& desc_a,info,itmax,iter,err,itrace,istop,cond)
use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
use psb_prec_mod, only : psb_dprec_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
real(psb_dpk_), intent(in) :: b(:)
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(in) :: eps
class(psb_dprec_type), intent(in) :: prec
integer, intent(out) :: info
integer, optional, intent(in) :: itmax, itrace,istop
integer, optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err,cond
end subroutine psb_dcg
subroutine psb_dbicg(a,prec,b,x,eps,&
& desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
use psb_prec_mod, only : psb_dprec_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
real(psb_dpk_), intent(in) :: b(:)
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(in) :: eps
class(psb_dprec_type), intent(in) :: prec
integer, intent(out) :: info
integer, optional, intent(in) :: itmax, itrace,istop
integer, optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
end subroutine psb_dbicg
subroutine psb_dcgstab(a,prec,b,x,eps,&
& desc_a,info,itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
use psb_prec_mod, only : psb_dprec_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
real(psb_dpk_), intent(in) :: b(:)
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(in) :: eps
class(psb_dprec_type), intent(in) :: prec
integer, intent(out) :: info
integer, optional, intent(in) :: itmax, itrace,istop
integer, optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
end subroutine psb_dcgstab
Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err, itrace,irst,istop)
use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
use psb_prec_mod, only : psb_dprec_type
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_dprec_type), intent(in) :: prec
Real(psb_dpk_), Intent(in) :: b(:)
Real(psb_dpk_), Intent(inout) :: x(:)
Real(psb_dpk_), Intent(in) :: eps
integer, intent(out) :: info
Integer, Optional, Intent(in) :: itmax, itrace, irst,istop
Integer, Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
end subroutine psb_dcgstabl
Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,irst,istop)
use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
use psb_prec_mod, only : psb_dprec_type
Type(psb_dspmat_type), Intent(in) :: a
Type(psb_desc_type), Intent(in) :: desc_a
class(psb_dprec_type), intent(in) :: prec
Real(psb_dpk_), Intent(in) :: b(:)
Real(psb_dpk_), Intent(inout) :: x(:)
Real(psb_dpk_), Intent(in) :: eps
integer, intent(out) :: info
Integer, Optional, Intent(in) :: itmax, itrace, irst,istop
Integer, Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
end subroutine psb_drgmres
subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,istop)
use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
use psb_prec_mod, only : psb_dprec_type
type(psb_dspmat_type), intent(in) :: a
type(psb_desc_type), intent(in) :: desc_a
class(psb_dprec_type), intent(in) :: prec
real(psb_dpk_), intent(in) :: b(:)
real(psb_dpk_), intent(inout) :: x(:)
real(psb_dpk_), intent(in) :: eps
integer, intent(out) :: info
integer, optional, intent(in) :: itmax, itrace,istop
integer, optional, intent(out) :: iter
real(psb_dpk_), optional, intent(out) :: err
end subroutine psb_dcgs
end interface
integer :: ictxt,me,np,err_act
character(len=20) :: name
info = psb_success_
name = 'psb_krylov'
call psb_erractionsave(err_act)
ictxt=desc_a%get_context()
call psb_info(ictxt, me, np)
select case(psb_toupper(method))
case('CG')
call psb_dcg(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,istop,cond)
case('CGS')
call psb_dcgs(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,istop)
case('BICG')
call psb_dbicg(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,istop)
case('BICGSTAB')
call psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,istop)
case('RGMRES')
call psb_drgmres(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,irst,istop)
case('BICGSTABL')
call psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,irst,istop)
case default
if (me == 0) write(psb_err_unit,*) trim(name),': Warning: Unknown method ',method,&
& ', defaulting to BiCGSTAB'
call psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
&itmax,iter,err,itrace,istop)
end select
if(info /= psb_success_) then
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(ictxt)
return
end if
end subroutine psb_dkrylov
!!$Subroutine psb_dkrylov(method,a,prec,b,x,eps,desc_a,info,&
!!$ & itmax,iter,err,itrace,irst,istop,cond)
!!$
!!$ use psb_base_mod
!!$ use psb_prec_mod,only : psb_sprec_type, psb_dprec_type, psb_cprec_type, psb_zprec_type
!!$ use psb_krylov_mod, psb_protect_name => psb_dkrylov
!!$
!!$ character(len=*) :: method
!!$ Type(psb_dspmat_type), Intent(in) :: a
!!$ Type(psb_desc_type), Intent(in) :: desc_a
!!$ class(psb_dprec_type), intent(in) :: prec
!!$ Real(psb_dpk_), Intent(in) :: b(:)
!!$ Real(psb_dpk_), Intent(inout) :: x(:)
!!$ Real(psb_dpk_), Intent(in) :: eps
!!$ integer, intent(out) :: info
!!$ Integer, Optional, Intent(in) :: itmax, itrace, irst,istop
!!$ Integer, Optional, Intent(out) :: iter
!!$ Real(psb_dpk_), Optional, Intent(out) :: err,cond
!!$
!!$ interface
!!$ subroutine psb_dcg(a,prec,b,x,eps,&
!!$ & desc_a,info,itmax,iter,err,itrace,istop,cond)
!!$ use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
!!$ use psb_prec_mod, only : psb_dprec_type
!!$ type(psb_dspmat_type), intent(in) :: a
!!$ type(psb_desc_type), intent(in) :: desc_a
!!$ real(psb_dpk_), intent(in) :: b(:)
!!$ real(psb_dpk_), intent(inout) :: x(:)
!!$ real(psb_dpk_), intent(in) :: eps
!!$ class(psb_dprec_type), intent(in) :: prec
!!$ integer, intent(out) :: info
!!$ integer, optional, intent(in) :: itmax, itrace,istop
!!$ integer, optional, intent(out) :: iter
!!$ real(psb_dpk_), optional, intent(out) :: err,cond
!!$ end subroutine psb_dcg
!!$ subroutine psb_dbicg(a,prec,b,x,eps,&
!!$ & desc_a,info,itmax,iter,err,itrace,istop)
!!$ use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
!!$ use psb_prec_mod, only : psb_dprec_type
!!$ type(psb_dspmat_type), intent(in) :: a
!!$ type(psb_desc_type), intent(in) :: desc_a
!!$ real(psb_dpk_), intent(in) :: b(:)
!!$ real(psb_dpk_), intent(inout) :: x(:)
!!$ real(psb_dpk_), intent(in) :: eps
!!$ class(psb_dprec_type), intent(in) :: prec
!!$ integer, intent(out) :: info
!!$ integer, optional, intent(in) :: itmax, itrace,istop
!!$ integer, optional, intent(out) :: iter
!!$ real(psb_dpk_), optional, intent(out) :: err
!!$ end subroutine psb_dbicg
!!$ subroutine psb_dcgstab(a,prec,b,x,eps,&
!!$ & desc_a,info,itmax,iter,err,itrace,istop)
!!$ use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
!!$ use psb_prec_mod, only : psb_dprec_type
!!$ type(psb_dspmat_type), intent(in) :: a
!!$ type(psb_desc_type), intent(in) :: desc_a
!!$ real(psb_dpk_), intent(in) :: b(:)
!!$ real(psb_dpk_), intent(inout) :: x(:)
!!$ real(psb_dpk_), intent(in) :: eps
!!$ class(psb_dprec_type), intent(in) :: prec
!!$ integer, intent(out) :: info
!!$ integer, optional, intent(in) :: itmax, itrace,istop
!!$ integer, optional, intent(out) :: iter
!!$ real(psb_dpk_), optional, intent(out) :: err
!!$ end subroutine psb_dcgstab
!!$ Subroutine psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
!!$ &itmax,iter,err, itrace,irst,istop)
!!$ use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
!!$ use psb_prec_mod, only : psb_dprec_type
!!$ Type(psb_dspmat_type), Intent(in) :: a
!!$ Type(psb_desc_type), Intent(in) :: desc_a
!!$ class(psb_dprec_type), intent(in) :: prec
!!$ Real(psb_dpk_), Intent(in) :: b(:)
!!$ Real(psb_dpk_), Intent(inout) :: x(:)
!!$ Real(psb_dpk_), Intent(in) :: eps
!!$ integer, intent(out) :: info
!!$ Integer, Optional, Intent(in) :: itmax, itrace, irst,istop
!!$ Integer, Optional, Intent(out) :: iter
!!$ Real(psb_dpk_), Optional, Intent(out) :: err
!!$ end subroutine psb_dcgstabl
!!$ Subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,&
!!$ &itmax,iter,err,itrace,irst,istop)
!!$ use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
!!$ use psb_prec_mod, only : psb_dprec_type
!!$ Type(psb_dspmat_type), Intent(in) :: a
!!$ Type(psb_desc_type), Intent(in) :: desc_a
!!$ class(psb_dprec_type), intent(in) :: prec
!!$ Real(psb_dpk_), Intent(in) :: b(:)
!!$ Real(psb_dpk_), Intent(inout) :: x(:)
!!$ Real(psb_dpk_), Intent(in) :: eps
!!$ integer, intent(out) :: info
!!$ Integer, Optional, Intent(in) :: itmax, itrace, irst,istop
!!$ Integer, Optional, Intent(out) :: iter
!!$ Real(psb_dpk_), Optional, Intent(out) :: err
!!$ end subroutine psb_drgmres
!!$ subroutine psb_dcgs(a,prec,b,x,eps,desc_a,info,&
!!$ &itmax,iter,err,itrace,istop)
!!$ use psb_base_mod, only : psb_desc_type, psb_dspmat_type, psb_dpk_
!!$ use psb_prec_mod, only : psb_dprec_type
!!$ type(psb_dspmat_type), intent(in) :: a
!!$ type(psb_desc_type), intent(in) :: desc_a
!!$ class(psb_dprec_type), intent(in) :: prec
!!$ real(psb_dpk_), intent(in) :: b(:)
!!$ real(psb_dpk_), intent(inout) :: x(:)
!!$ real(psb_dpk_), intent(in) :: eps
!!$ integer, intent(out) :: info
!!$ integer, optional, intent(in) :: itmax, itrace,istop
!!$ integer, optional, intent(out) :: iter
!!$ real(psb_dpk_), optional, intent(out) :: err
!!$ end subroutine psb_dcgs
!!$ end interface
!!$ integer :: ictxt,me,np,err_act
!!$ character(len=20) :: name
!!$
!!$ info = psb_success_
!!$ name = 'psb_krylov'
!!$ call psb_erractionsave(err_act)
!!$
!!$
!!$ ictxt=desc_a%get_context()
!!$
!!$ call psb_info(ictxt, me, np)
!!$
!!$ select case(psb_toupper(method))
!!$ case('CG')
!!$ call psb_dcg(a,prec,b,x,eps,desc_a,info,&
!!$ &itmax,iter,err,itrace,istop,cond)
!!$ case('CGS')
!!$ call psb_dcgs(a,prec,b,x,eps,desc_a,info,&
!!$ &itmax,iter,err,itrace,istop)
!!$ case('BICG')
!!$ call psb_dbicg(a,prec,b,x,eps,desc_a,info,&
!!$ &itmax,iter,err,itrace,istop)
!!$ case('BICGSTAB')
!!$ call psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
!!$ &itmax,iter,err,itrace,istop)
!!$ case('RGMRES')
!!$ call psb_drgmres(a,prec,b,x,eps,desc_a,info,&
!!$ &itmax,iter,err,itrace,irst,istop)
!!$ case('BICGSTABL')
!!$ call psb_dcgstabl(a,prec,b,x,eps,desc_a,info,&
!!$ &itmax,iter,err,itrace,irst,istop)
!!$ case default
!!$ if (me == 0) write(psb_err_unit,*) trim(name),': Warning: Unknown method ',method,&
!!$ & ', defaulting to BiCGSTAB'
!!$ call psb_dcgstab(a,prec,b,x,eps,desc_a,info,&
!!$ &itmax,iter,err,itrace,istop)
!!$ end select
!!$
!!$ if(info /= psb_success_) then
!!$ 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(ictxt)
!!$ return
!!$ end if
!!$
!!$end subroutine psb_dkrylov
Subroutine psb_dkrylov_vect(method,a,prec,b,x,eps,desc_a,info,&
& itmax,iter,err,itrace,irst,istop,cond)
krylov/psb_drgmres.f90
+359 -359
View File
@@ -106,365 +106,365 @@
! irst - integer(optional) Input: restart parameter
!
!
subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop)
use psb_base_mod
use psb_prec_mod
use psb_d_inner_krylov_mod
use psb_krylov_mod
implicit none
type(psb_dspmat_type), intent(in) :: a
class(psb_dprec_type), Intent(in) :: prec
Type(psb_desc_type), Intent(in) :: desc_a
Real(psb_dpk_), Intent(in) :: b(:)
Real(psb_dpk_), Intent(inout) :: x(:)
Real(psb_dpk_), Intent(in) :: eps
integer, intent(out) :: info
Integer, Optional, Intent(in) :: itmax, itrace, irst,istop
Integer, Optional, Intent(out) :: iter
Real(psb_dpk_), Optional, Intent(out) :: err
!!$ local data
Real(psb_dpk_), allocatable, target :: aux(:),w(:),w1(:), v(:,:)
Real(psb_dpk_), allocatable :: c(:),s(:), h(:,:), rs(:),rst(:),xt(:)
Real(psb_dpk_) :: scal, gm, rti, rti1
Integer ::litmax, naux, mglob, it,k, itrace_,&
& np,me, n_row, n_col, nl, int_err(5)
Logical, Parameter :: exchange=.True., noexchange=.False., use_drot=.true.
Integer, Parameter :: irmax = 8
Integer :: itx, i, isvch, ictxt,istop_, err_act
integer :: debug_level, debug_unit
Real(psb_dpk_) :: rni, xni, bni, ani,bn2, dt
real(psb_dpk_), external :: dnrm2
real(psb_dpk_) :: errnum, errden
character(len=20) :: name
character(len=*), parameter :: methdname='RGMRES'
info = psb_success_
name = 'psb_dgmres'
call psb_erractionsave(err_act)
debug_unit = psb_get_debug_unit()
debug_level = psb_get_debug_level()
ictxt = desc_a%get_context()
Call psb_info(ictxt, me, np)
if (debug_level >= psb_debug_ext_)&
& write(debug_unit,*) me,' ',trim(name),': from psb_info',np
mglob = desc_a%get_global_rows()
n_row = desc_a%get_local_rows()
n_col = desc_a%get_local_cols()
if (present(istop)) then
istop_ = istop
else
istop_ = 2
endif
!
! ISTOP_ = 1: Normwise backward error, infinity norm
! ISTOP_ = 2: ||r||/||b||, 2-norm
!
if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
info=psb_err_invalid_istop_
int_err(1)=istop_
err=info
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
if (present(itmax)) then
litmax = itmax
else
litmax = 1000
endif
if (present(itrace)) then
itrace_ = itrace
else
itrace_ = 0
end if
if (present(irst)) then
nl = irst
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' present: irst: ',irst,nl
else
nl = 10
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' not present: irst: ',irst,nl
endif
if (nl <=0 ) then
info=psb_err_invalid_istop_
int_err(1)=nl
err=info
call psb_errpush(info,name,i_err=int_err)
goto 9999
endif
call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_chkvect on X')
goto 9999
end if
call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
if(info /= psb_success_) then
info=psb_err_from_subroutine_
call psb_errpush(info,name,a_err='psb_chkvect on B')
goto 9999
end if
naux=4*n_col
allocate(aux(naux),h(nl+1,nl+1),&
&c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info)
if (info == psb_success_) call psb_geall(v,desc_a,info,n=nl+1)
if (info == psb_success_) call psb_geall(w,desc_a,info)
if (info == psb_success_) call psb_geall(w1,desc_a,info)
if (info == psb_success_) call psb_geall(xt,desc_a,info)
if (info == psb_success_) call psb_geasb(v,desc_a,info)
if (info == psb_success_) call psb_geasb(w,desc_a,info)
if (info == psb_success_) call psb_geasb(w1,desc_a,info)
if (info == psb_success_) call psb_geasb(xt,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Size of V,W,W1 ',size(v),size(v,1),&
& size(w),size(w,1),size(w1),size(w1,1), size(v(:,1))
! Ensure global coherence for convergence checks.
call psb_set_coher(ictxt,isvch)
if (istop_ == 1) then
ani = psb_spnrmi(a,desc_a,info)
bni = psb_geamax(b,desc_a,info)
else if (istop_ == 2) then
bn2 = psb_genrm2(b,desc_a,info)
endif
errnum = dzero
errden = done
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
if ((itrace_ > 0).and.(me == 0)) call log_header(methdname)
itx = 0
restart: do
! compute r0 = b-ax0
! check convergence
! compute v1 = r0/||r0||_2
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' restart: ',itx,it
it = 0
call psb_geaxpby(done,b,dzero,v(:,1),desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
call psb_spmm(-done,a,x,done,v(:,1),desc_a,info,work=aux)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
rs(1) = psb_genrm2(v(:,1),desc_a,info)
rs(2:) = dzero
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT?
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' on entry to amax: b: ',Size(b),rs(1),scal
!
! check convergence
!
if (istop_ == 1) then
rni = psb_geamax(v(:,1),desc_a,info)
xni = psb_geamax(x,desc_a,info)
errnum = rni
errden = (ani*xni+bni)
else if (istop_ == 2) then
rni = psb_genrm2(v(:,1),desc_a,info)
errnum = rni
errden = bn2
endif
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
if (errnum <= eps*errden) exit restart
if (itrace_ > 0) &
& call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
v(:,1) = v(:,1) * scal
if (itx >= litmax) exit restart
!
! inner iterations
!
inner: Do i=1,nl
itx = itx + 1
call prec%apply(v(:,i),w1,desc_a,info)
call psb_spmm(done,a,w1,dzero,w,desc_a,info,work=aux)
!
do k = 1, i
h(k,i) = psb_gedot(v(:,k),w,desc_a,info)
call psb_geaxpby(-h(k,i),v(:,k),done,w,desc_a,info)
end do
h(i+1,i) = psb_genrm2(w,desc_a,info)
scal=done/h(i+1,i)
call psb_geaxpby(scal,w,dzero,v(:,i+1),desc_a,info)
do k=2,i
call drot(1,h(k-1,i),1,h(k,i),1,c(k-1),s(k-1))
enddo
rti = h(i,i)
rti1 = h(i+1,i)
call drotg(rti,rti1,c(i),s(i))
call drot(1,h(i,i),1,h(i+1,i),1,c(i),s(i))
h(i+1,i) = dzero
call drot(1,rs(i),1,rs(i+1),1,c(i),s(i))
if (istop_ == 1) then
!
! build x and then compute the residual and its infinity norm
!
rst = rs
xt = dzero
call dtrsm('l','u','n','n',i,1,done,h,size(h,1),rst,size(rst,1))
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Rebuild x-> RS:',rst(1:nl)
do k=1, i
call psb_geaxpby(rst(k),v(:,k),done,xt,desc_a,info)
end do
call prec%apply(xt,desc_a,info)
call psb_geaxpby(done,x,done,xt,desc_a,info)
call psb_geaxpby(done,b,dzero,w1,desc_a,info)
call psb_spmm(-done,a,xt,done,w1,desc_a,info,work=aux)
rni = psb_geamax(w1,desc_a,info)
xni = psb_geamax(xt,desc_a,info)
errnum = rni
errden = (ani*xni+bni)
!
else if (istop_ == 2) then
!
! compute the residual 2-norm as byproduct of the solution
! procedure of the least-squares problem
!
rni = abs(rs(i+1))
errnum = rni
errden = bn2
endif
if (errnum <= eps*errden) then
if (istop_ == 1) then
x = xt
else if (istop_ == 2) then
!
! build x
!
call dtrsm('l','u','n','n',i,1,done,h,size(h,1),rs,size(rs,1))
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Rebuild x-> RS:',rs(1:nl)
w1 = dzero
do k=1, i
call psb_geaxpby(rs(k),v(:,k),done,w1,desc_a,info)
end do
call prec%apply(w1,w,desc_a,info)
call psb_geaxpby(done,w,done,x,desc_a,info)
end if
exit restart
end if
if (itrace_ > 0) &
& call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
end do inner
if (istop_ == 1) then
x = xt
else if (istop_ == 2) then
!
! build x
!
call dtrsm('l','u','n','n',nl,1,done,h,size(h,1),rs,size(rs,1))
if (debug_level >= psb_debug_ext_) &
& write(debug_unit,*) me,' ',trim(name),&
& ' Rebuild x-> RS:',rs(1:nl)
w1 = dzero
do k=1, nl
call psb_geaxpby(rs(k),v(:,k),done,w1,desc_a,info)
end do
call prec%apply(w1,w,desc_a,info)
call psb_geaxpby(done,w,done,x,desc_a,info)
end if
end do restart
if (itrace_ > 0) &
& call log_conv(methdname,me,itx,1,errnum,errden,eps)
call log_end(methdname,me,itx,errnum,errden,eps,err=err,iter=iter)
deallocate(aux,h,c,s,rs,rst, stat=info)
if (info == psb_success_) call psb_gefree(v,desc_a,info)
if (info == psb_success_) call psb_gefree(w,desc_a,info)
if (info == psb_success_) call psb_gefree(w1,desc_a,info)
if (info == psb_success_) call psb_gefree(xt,desc_a,info)
if (info /= psb_success_) then
info=psb_err_from_subroutine_non_
call psb_errpush(info,name)
goto 9999
end if
! restore external global coherence behaviour
call psb_restore_coher(ictxt,isvch)
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_drgmres
!!$subroutine psb_drgmres(a,prec,b,x,eps,desc_a,info,itmax,iter,err,itrace,irst,istop)
!!$ use psb_base_mod
!!$ use psb_prec_mod
!!$ use psb_d_inner_krylov_mod
!!$ use psb_krylov_mod
!!$ implicit none
!!$ type(psb_dspmat_type), intent(in) :: a
!!$
!!$
!!$ class(psb_dprec_type), Intent(in) :: prec
!!$ Type(psb_desc_type), Intent(in) :: desc_a
!!$ Real(psb_dpk_), Intent(in) :: b(:)
!!$ Real(psb_dpk_), Intent(inout) :: x(:)
!!$ Real(psb_dpk_), Intent(in) :: eps
!!$ integer, intent(out) :: info
!!$ Integer, Optional, Intent(in) :: itmax, itrace, irst,istop
!!$ Integer, Optional, Intent(out) :: iter
!!$ Real(psb_dpk_), Optional, Intent(out) :: err
!!$! !$ local data
!!$ Real(psb_dpk_), allocatable, target :: aux(:),w(:),w1(:), v(:,:)
!!$ Real(psb_dpk_), allocatable :: c(:),s(:), h(:,:), rs(:),rst(:),xt(:)
!!$ Real(psb_dpk_) :: scal, gm, rti, rti1
!!$ Integer ::litmax, naux, mglob, it,k, itrace_,&
!!$ & np,me, n_row, n_col, nl, int_err(5)
!!$ Logical, Parameter :: exchange=.True., noexchange=.False., use_drot=.true.
!!$ Integer, Parameter :: irmax = 8
!!$ Integer :: itx, i, isvch, ictxt,istop_, err_act
!!$ integer :: debug_level, debug_unit
!!$ Real(psb_dpk_) :: rni, xni, bni, ani,bn2, dt
!!$ real(psb_dpk_), external :: dnrm2
!!$ real(psb_dpk_) :: errnum, errden
!!$ character(len=20) :: name
!!$ character(len=*), parameter :: methdname='RGMRES'
!!$
!!$ info = psb_success_
!!$ name = 'psb_dgmres'
!!$ call psb_erractionsave(err_act)
!!$ debug_unit = psb_get_debug_unit()
!!$ debug_level = psb_get_debug_level()
!!$
!!$ ictxt = desc_a%get_context()
!!$ Call psb_info(ictxt, me, np)
!!$ if (debug_level >= psb_debug_ext_)&
!!$ & write(debug_unit,*) me,' ',trim(name),': from psb_info',np
!!$
!!$ mglob = desc_a%get_global_rows()
!!$ n_row = desc_a%get_local_rows()
!!$ n_col = desc_a%get_local_cols()
!!$
!!$ if (present(istop)) then
!!$ istop_ = istop
!!$ else
!!$ istop_ = 2
!!$ endif
!!$!
!!$! ISTOP_ = 1: Normwise backward error, infinity norm
!!$! ISTOP_ = 2: ||r||/||b||, 2-norm
!!$!
!!$
!!$ if ((istop_ < 1 ).or.(istop_ > 2 ) ) then
!!$ info=psb_err_invalid_istop_
!!$ int_err(1)=istop_
!!$ err=info
!!$ call psb_errpush(info,name,i_err=int_err)
!!$ goto 9999
!!$ endif
!!$
!!$ if (present(itmax)) then
!!$ litmax = itmax
!!$ else
!!$ litmax = 1000
!!$ endif
!!$
!!$ if (present(itrace)) then
!!$ itrace_ = itrace
!!$ else
!!$ itrace_ = 0
!!$ end if
!!$
!!$ if (present(irst)) then
!!$ nl = irst
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' present: irst: ',irst,nl
!!$ else
!!$ nl = 10
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' not present: irst: ',irst,nl
!!$ endif
!!$ if (nl <=0 ) then
!!$ info=psb_err_invalid_istop_
!!$ int_err(1)=nl
!!$ err=info
!!$ call psb_errpush(info,name,i_err=int_err)
!!$ goto 9999
!!$ endif
!!$
!!$ call psb_chkvect(mglob,1,size(x,1),1,1,desc_a,info)
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_chkvect on X')
!!$ goto 9999
!!$ end if
!!$ call psb_chkvect(mglob,1,size(b,1),1,1,desc_a,info)
!!$ if(info /= psb_success_) then
!!$ info=psb_err_from_subroutine_
!!$ call psb_errpush(info,name,a_err='psb_chkvect on B')
!!$ goto 9999
!!$ end if
!!$
!!$
!!$ naux=4*n_col
!!$ allocate(aux(naux),h(nl+1,nl+1),&
!!$ &c(nl+1),s(nl+1),rs(nl+1), rst(nl+1),stat=info)
!!$
!!$ if (info == psb_success_) call psb_geall(v,desc_a,info,n=nl+1)
!!$ if (info == psb_success_) call psb_geall(w,desc_a,info)
!!$ if (info == psb_success_) call psb_geall(w1,desc_a,info)
!!$ if (info == psb_success_) call psb_geall(xt,desc_a,info)
!!$ if (info == psb_success_) call psb_geasb(v,desc_a,info)
!!$ if (info == psb_success_) call psb_geasb(w,desc_a,info)
!!$ if (info == psb_success_) call psb_geasb(w1,desc_a,info)
!!$ if (info == psb_success_) call psb_geasb(xt,desc_a,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Size of V,W,W1 ',size(v),size(v,1),&
!!$ & size(w),size(w,1),size(w1),size(w1,1), size(v(:,1))
!!$
!!$ ! Ensure global coherence for convergence checks.
!!$ call psb_set_coher(ictxt,isvch)
!!$
!!$ if (istop_ == 1) then
!!$ ani = psb_spnrmi(a,desc_a,info)
!!$ bni = psb_geamax(b,desc_a,info)
!!$ else if (istop_ == 2) then
!!$ bn2 = psb_genrm2(b,desc_a,info)
!!$ endif
!!$ errnum = dzero
!!$ errden = done
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ if ((itrace_ > 0).and.(me == 0)) call log_header(methdname)
!!$
!!$ itx = 0
!!$ restart: do
!!$
!!$ ! compute r0 = b-ax0
!!$ ! check convergence
!!$ ! compute v1 = r0/||r0||_2
!!$
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' restart: ',itx,it
!!$ it = 0
!!$ call psb_geaxpby(done,b,dzero,v(:,1),desc_a,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ call psb_spmm(-done,a,x,done,v(:,1),desc_a,info,work=aux)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ rs(1) = psb_genrm2(v(:,1),desc_a,info)
!!$ rs(2:) = dzero
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$ scal=done/rs(1) ! rs(1) MIGHT BE VERY SMALL - USE DSCAL TO DEAL WITH IT?
!!$
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' on entry to amax: b: ',Size(b),rs(1),scal
!!$
!!$ !
!!$ ! check convergence
!!$ !
!!$ if (istop_ == 1) then
!!$ rni = psb_geamax(v(:,1),desc_a,info)
!!$ xni = psb_geamax(x,desc_a,info)
!!$ errnum = rni
!!$ errden = (ani*xni+bni)
!!$ else if (istop_ == 2) then
!!$ rni = psb_genrm2(v(:,1),desc_a,info)
!!$ errnum = rni
!!$ errden = bn2
!!$ endif
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ if (errnum <= eps*errden) exit restart
!!$
!!$ if (itrace_ > 0) &
!!$ & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
!!$
!!$ v(:,1) = v(:,1) * scal
!!$
!!$ if (itx >= litmax) exit restart
!!$
!!$ !
!!$ ! inner iterations
!!$ !
!!$
!!$ inner: Do i=1,nl
!!$ itx = itx + 1
!!$
!!$ call prec%apply(v(:,i),w1,desc_a,info)
!!$ call psb_spmm(done,a,w1,dzero,w,desc_a,info,work=aux)
!!$ !
!!$
!!$ do k = 1, i
!!$ h(k,i) = psb_gedot(v(:,k),w,desc_a,info)
!!$ call psb_geaxpby(-h(k,i),v(:,k),done,w,desc_a,info)
!!$ end do
!!$ h(i+1,i) = psb_genrm2(w,desc_a,info)
!!$ scal=done/h(i+1,i)
!!$ call psb_geaxpby(scal,w,dzero,v(:,i+1),desc_a,info)
!!$ do k=2,i
!!$ call drot(1,h(k-1,i),1,h(k,i),1,c(k-1),s(k-1))
!!$ enddo
!!$
!!$ rti = h(i,i)
!!$ rti1 = h(i+1,i)
!!$ call drotg(rti,rti1,c(i),s(i))
!!$ call drot(1,h(i,i),1,h(i+1,i),1,c(i),s(i))
!!$ h(i+1,i) = dzero
!!$ call drot(1,rs(i),1,rs(i+1),1,c(i),s(i))
!!$
!!$ if (istop_ == 1) then
!!$ !
!!$ ! build x and then compute the residual and its infinity norm
!!$ !
!!$ rst = rs
!!$ xt = dzero
!!$ call dtrsm('l','u','n','n',i,1,done,h,size(h,1),rst,size(rst,1))
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Rebuild x-> RS:',rst(1:nl)
!!$ do k=1, i
!!$ call psb_geaxpby(rst(k),v(:,k),done,xt,desc_a,info)
!!$ end do
!!$ call prec%apply(xt,desc_a,info)
!!$ call psb_geaxpby(done,x,done,xt,desc_a,info)
!!$ call psb_geaxpby(done,b,dzero,w1,desc_a,info)
!!$ call psb_spmm(-done,a,xt,done,w1,desc_a,info,work=aux)
!!$ rni = psb_geamax(w1,desc_a,info)
!!$ xni = psb_geamax(xt,desc_a,info)
!!$ errnum = rni
!!$ errden = (ani*xni+bni)
!!$ !
!!$
!!$ else if (istop_ == 2) then
!!$ !
!!$ ! compute the residual 2-norm as byproduct of the solution
!!$ ! procedure of the least-squares problem
!!$ !
!!$ rni = abs(rs(i+1))
!!$ errnum = rni
!!$ errden = bn2
!!$ endif
!!$
!!$ if (errnum <= eps*errden) then
!!$
!!$ if (istop_ == 1) then
!!$ x = xt
!!$ else if (istop_ == 2) then
!!$ !
!!$ ! build x
!!$ !
!!$ call dtrsm('l','u','n','n',i,1,done,h,size(h,1),rs,size(rs,1))
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Rebuild x-> RS:',rs(1:nl)
!!$ w1 = dzero
!!$ do k=1, i
!!$ call psb_geaxpby(rs(k),v(:,k),done,w1,desc_a,info)
!!$ end do
!!$ call prec%apply(w1,w,desc_a,info)
!!$ call psb_geaxpby(done,w,done,x,desc_a,info)
!!$ end if
!!$
!!$ exit restart
!!$
!!$ end if
!!$
!!$ if (itrace_ > 0) &
!!$ & call log_conv(methdname,me,itx,itrace_,errnum,errden,eps)
!!$
!!$ end do inner
!!$
!!$ if (istop_ == 1) then
!!$ x = xt
!!$ else if (istop_ == 2) then
!!$ !
!!$ ! build x
!!$ !
!!$ call dtrsm('l','u','n','n',nl,1,done,h,size(h,1),rs,size(rs,1))
!!$ if (debug_level >= psb_debug_ext_) &
!!$ & write(debug_unit,*) me,' ',trim(name),&
!!$ & ' Rebuild x-> RS:',rs(1:nl)
!!$ w1 = dzero
!!$ do k=1, nl
!!$ call psb_geaxpby(rs(k),v(:,k),done,w1,desc_a,info)
!!$ end do
!!$ call prec%apply(w1,w,desc_a,info)
!!$ call psb_geaxpby(done,w,done,x,desc_a,info)
!!$ end if
!!$
!!$ end do restart
!!$ if (itrace_ > 0) &
!!$ & call log_conv(methdname,me,itx,1,errnum,errden,eps)
!!$
!!$ call log_end(methdname,me,itx,errnum,errden,eps,err=err,iter=iter)
!!$
!!$ deallocate(aux,h,c,s,rs,rst, stat=info)
!!$ if (info == psb_success_) call psb_gefree(v,desc_a,info)
!!$ if (info == psb_success_) call psb_gefree(w,desc_a,info)
!!$ if (info == psb_success_) call psb_gefree(w1,desc_a,info)
!!$ if (info == psb_success_) call psb_gefree(xt,desc_a,info)
!!$ if (info /= psb_success_) then
!!$ info=psb_err_from_subroutine_non_
!!$ call psb_errpush(info,name)
!!$ goto 9999
!!$ end if
!!$
!!$ ! restore external global coherence behaviour
!!$ call psb_restore_coher(ictxt,isvch)
!!$
!!$ 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_drgmres
subroutine psb_drgmres_vect(a,prec,b,x,eps,desc_a,info,&
prec/psb_c_diagprec.f90
+1 -1
View File
@@ -95,7 +95,7 @@ contains
end if
end if
2 call psb_erractionrestore(err_act)
call psb_erractionrestore(err_act)
return
9999 continue