diff --git a/base/modules/psb_c_base_vect_mod.f90 b/base/modules/psb_c_base_vect_mod.f90 index 249134319..0dba48b6c 100644 --- a/base/modules/psb_c_base_vect_mod.f90 +++ b/base/modules/psb_c_base_vect_mod.f90 @@ -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) diff --git a/base/modules/psb_c_mat_mod.f90 b/base/modules/psb_c_mat_mod.f90 index 0b533b162..b61c3d451 100644 --- a/base/modules/psb_c_mat_mod.f90 +++ b/base/modules/psb_c_mat_mod.f90 @@ -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 diff --git a/base/modules/psb_d_base_vect_mod.f90 b/base/modules/psb_d_base_vect_mod.f90 index dc555e058..f3422e8c4 100644 --- a/base/modules/psb_d_base_vect_mod.f90 +++ b/base/modules/psb_d_base_vect_mod.f90 @@ -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) diff --git a/base/modules/psb_d_mat_mod.f90 b/base/modules/psb_d_mat_mod.f90 index bec54939b..066e24fce 100644 --- a/base/modules/psb_d_mat_mod.f90 +++ b/base/modules/psb_d_mat_mod.f90 @@ -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 diff --git a/base/modules/psb_s_base_mat_mod.f90 b/base/modules/psb_s_base_mat_mod.f90 index caded0fa2..5329f66d5 100644 --- a/base/modules/psb_s_base_mat_mod.f90 +++ b/base/modules/psb_s_base_mat_mod.f90 @@ -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 diff --git a/base/modules/psb_s_base_vect_mod.f90 b/base/modules/psb_s_base_vect_mod.f90 index 6972893be..d373a6445 100644 --- a/base/modules/psb_s_base_vect_mod.f90 +++ b/base/modules/psb_s_base_vect_mod.f90 @@ -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) diff --git a/base/modules/psb_s_mat_mod.f90 b/base/modules/psb_s_mat_mod.f90 index ec3806f9e..dfc2e491f 100644 --- a/base/modules/psb_s_mat_mod.f90 +++ b/base/modules/psb_s_mat_mod.f90 @@ -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 diff --git a/base/modules/psb_z_base_vect_mod.f90 b/base/modules/psb_z_base_vect_mod.f90 index 6b2eb154a..990184d64 100644 --- a/base/modules/psb_z_base_vect_mod.f90 +++ b/base/modules/psb_z_base_vect_mod.f90 @@ -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 diff --git a/base/modules/psb_z_mat_mod.f90 b/base/modules/psb_z_mat_mod.f90 index 96369ea44..58e0542ee 100644 --- a/base/modules/psb_z_mat_mod.f90 +++ b/base/modules/psb_z_mat_mod.f90 @@ -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 diff --git a/base/serial/impl/psb_c_base_mat_impl.f90 b/base/serial/impl/psb_c_base_mat_impl.f90 index 87811d4b1..c10a47256 100644 --- a/base/serial/impl/psb_c_base_mat_impl.f90 +++ b/base/serial/impl/psb_c_base_mat_impl.f90 @@ -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 - - diff --git a/base/serial/impl/psb_c_coo_impl.f90 b/base/serial/impl/psb_c_coo_impl.f90 index deb537cc9..9976ed77a 100644 --- a/base/serial/impl/psb_c_coo_impl.f90 +++ b/base/serial/impl/psb_c_coo_impl.f90 @@ -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) diff --git a/base/serial/impl/psb_c_csc_impl.f90 b/base/serial/impl/psb_c_csc_impl.f90 index 41f40b003..ae11bab9b 100644 --- a/base/serial/impl/psb_c_csc_impl.f90 +++ b/base/serial/impl/psb_c_csc_impl.f90 @@ -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) 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_ diff --git a/base/serial/impl/psb_d_base_mat_impl.f90 b/base/serial/impl/psb_d_base_mat_impl.f90 index 0a5f07633..a760b7b93 100644 --- a/base/serial/impl/psb_d_base_mat_impl.f90 +++ b/base/serial/impl/psb_d_base_mat_impl.f90 @@ -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. ! diff --git a/base/serial/impl/psb_d_coo_impl.f90 b/base/serial/impl/psb_d_coo_impl.f90 index 01d125070..a5dd2b6b0 100644 --- a/base/serial/impl/psb_d_coo_impl.f90 +++ b/base/serial/impl/psb_d_coo_impl.f90 @@ -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) diff --git a/base/serial/impl/psb_d_csc_impl.f90 b/base/serial/impl/psb_d_csc_impl.f90 index c31fa7a05..496f6b267 100644 --- a/base/serial/impl/psb_d_csc_impl.f90 +++ b/base/serial/impl/psb_d_csc_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_d_csr_impl.f90 b/base/serial/impl/psb_d_csr_impl.f90 index 2ffa51348..a9c3e8c26 100644 --- a/base/serial/impl/psb_d_csr_impl.f90 +++ b/base/serial/impl/psb_d_csr_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_d_mat_impl.F90 b/base/serial/impl/psb_d_mat_impl.F90 index df7cef02c..ab80b8f7f 100644 --- a/base/serial/impl/psb_d_mat_impl.F90 +++ b/base/serial/impl/psb_d_mat_impl.F90 @@ -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_ diff --git a/base/serial/impl/psb_s_base_mat_impl.f90 b/base/serial/impl/psb_s_base_mat_impl.f90 index f4f455c97..5f9400acf 100644 --- a/base/serial/impl/psb_s_base_mat_impl.f90 +++ b/base/serial/impl/psb_s_base_mat_impl.f90 @@ -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. ! diff --git a/base/serial/impl/psb_s_coo_impl.f90 b/base/serial/impl/psb_s_coo_impl.f90 index eb740b715..a89fd6621 100644 --- a/base/serial/impl/psb_s_coo_impl.f90 +++ b/base/serial/impl/psb_s_coo_impl.f90 @@ -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) diff --git a/base/serial/impl/psb_s_csc_impl.f90 b/base/serial/impl/psb_s_csc_impl.f90 index f445439ff..0cdf45117 100644 --- a/base/serial/impl/psb_s_csc_impl.f90 +++ b/base/serial/impl/psb_s_csc_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_s_csr_impl.f90 b/base/serial/impl/psb_s_csr_impl.f90 index db0936154..c4ae4d329 100644 --- a/base/serial/impl/psb_s_csr_impl.f90 +++ b/base/serial/impl/psb_s_csr_impl.f90 @@ -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 diff --git a/base/serial/impl/psb_s_mat_impl.F90 b/base/serial/impl/psb_s_mat_impl.F90 index 945a673fd..b545632a7 100644 --- a/base/serial/impl/psb_s_mat_impl.F90 +++ b/base/serial/impl/psb_s_mat_impl.F90 @@ -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_ diff --git a/base/serial/impl/psb_z_base_mat_impl.f90 b/base/serial/impl/psb_z_base_mat_impl.f90 index 85c4df768..ffa705b55 100644 --- a/base/serial/impl/psb_z_base_mat_impl.f90 +++ b/base/serial/impl/psb_z_base_mat_impl.f90 @@ -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 - - diff --git a/base/serial/impl/psb_z_coo_impl.f90 b/base/serial/impl/psb_z_coo_impl.f90 index 219b21ca5..e4a7a6eb6 100644 --- a/base/serial/impl/psb_z_coo_impl.f90 +++ b/base/serial/impl/psb_z_coo_impl.f90 @@ -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 + ! == ================================== ! ! diff --git a/base/serial/impl/psb_z_csc_impl.f90 b/base/serial/impl/psb_z_csc_impl.f90 index fd90d0bb3..cf91915b8 100644 --- a/base/serial/impl/psb_z_csc_impl.f90 +++ b/base/serial/impl/psb_z_csc_impl.f90 @@ -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) 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. diff --git a/krylov/psb_dbicg.f90 b/krylov/psb_dbicg.f90 index 848e82e91..4e9337619 100644 --- a/krylov/psb_dbicg.f90 +++ b/krylov/psb_dbicg.f90 @@ -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) diff --git a/krylov/psb_dcg.F90 b/krylov/psb_dcg.F90 index b44924fab..a6a4a7583 100644 --- a/krylov/psb_dcg.F90 +++ b/krylov/psb_dcg.F90 @@ -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) diff --git a/krylov/psb_dcgs.f90 b/krylov/psb_dcgs.f90 index 48019fd19..69c90f113 100644 --- a/krylov/psb_dcgs.f90 +++ b/krylov/psb_dcgs.f90 @@ -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) diff --git a/krylov/psb_dcgstab.F90 b/krylov/psb_dcgstab.F90 index 8e6f4d13d..40f2aa5cf 100644 --- a/krylov/psb_dcgstab.F90 +++ b/krylov/psb_dcgstab.F90 @@ -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) diff --git a/krylov/psb_dcgstabl.f90 b/krylov/psb_dcgstabl.f90 index a2ad1819e..05fb8444f 100644 --- a/krylov/psb_dcgstabl.f90 +++ b/krylov/psb_dcgstabl.f90 @@ -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) diff --git a/krylov/psb_dkrylov.f90 b/krylov/psb_dkrylov.f90 index 25ef69a2b..57b71ab4e 100644 --- a/krylov/psb_dkrylov.f90 +++ b/krylov/psb_dkrylov.f90 @@ -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) diff --git a/krylov/psb_drgmres.f90 b/krylov/psb_drgmres.f90 index 7901d9a31..fb55f800f 100644 --- a/krylov/psb_drgmres.f90 +++ b/krylov/psb_drgmres.f90 @@ -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,& diff --git a/prec/psb_c_diagprec.f90 b/prec/psb_c_diagprec.f90 index 7c2979c27..fc489b6cc 100644 --- a/prec/psb_c_diagprec.f90 +++ b/prec/psb_c_diagprec.f90 @@ -95,7 +95,7 @@ contains end if end if -2 call psb_erractionrestore(err_act) + call psb_erractionrestore(err_act) return 9999 continue