From 09d03941aff6940c992171a5c514ebfc8dfe2e66 Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Mon, 12 Dec 2022 14:38:06 +0100 Subject: [PATCH] psb_gescal Fortran semantic fix --- base/modules/psblas/psb_c_psblas_mod.F90 | 8 +++ base/modules/psblas/psb_d_psblas_mod.F90 | 8 +++ base/modules/psblas/psb_s_psblas_mod.F90 | 8 +++ base/modules/psblas/psb_z_psblas_mod.F90 | 8 +++ base/psblas/psb_caxpby.f90 | 72 ++++++++++++++++++++++++ base/psblas/psb_daxpby.f90 | 72 ++++++++++++++++++++++++ base/psblas/psb_saxpby.f90 | 72 ++++++++++++++++++++++++ base/psblas/psb_zaxpby.f90 | 72 ++++++++++++++++++++++++ krylov/psb_ckrylovsubspace_mod.F90 | 2 +- krylov/psb_dkrylovsubspace_mod.F90 | 2 +- krylov/psb_skrylovsubspace_mod.F90 | 2 +- krylov/psb_zkrylovsubspace_mod.F90 | 2 +- 12 files changed, 324 insertions(+), 4 deletions(-) diff --git a/base/modules/psblas/psb_c_psblas_mod.F90 b/base/modules/psblas/psb_c_psblas_mod.F90 index 4193daa3..4af63b72 100644 --- a/base/modules/psblas/psb_c_psblas_mod.F90 +++ b/base/modules/psblas/psb_c_psblas_mod.F90 @@ -618,6 +618,14 @@ module psb_c_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_cscal_vect + subroutine psb_cscal_inplace_vect(x,c,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_c_vect_type, psb_spk_ + type(psb_c_vect_type), intent (inout) :: x + complex(psb_spk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_cscal_inplace_vect end interface diff --git a/base/modules/psblas/psb_d_psblas_mod.F90 b/base/modules/psblas/psb_d_psblas_mod.F90 index 22332c40..9a8a3692 100644 --- a/base/modules/psblas/psb_d_psblas_mod.F90 +++ b/base/modules/psblas/psb_d_psblas_mod.F90 @@ -629,6 +629,14 @@ module psb_d_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_dscal_vect + subroutine psb_dscal_inplace_vect(x,c,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_d_vect_type, psb_dpk_ + type(psb_d_vect_type), intent (inout) :: x + real(psb_dpk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_dscal_inplace_vect end interface interface psb_mask diff --git a/base/modules/psblas/psb_s_psblas_mod.F90 b/base/modules/psblas/psb_s_psblas_mod.F90 index 43cca24b..9678cd06 100644 --- a/base/modules/psblas/psb_s_psblas_mod.F90 +++ b/base/modules/psblas/psb_s_psblas_mod.F90 @@ -629,6 +629,14 @@ module psb_s_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_sscal_vect + subroutine psb_sscal_inplace_vect(x,c,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_s_vect_type, psb_spk_ + type(psb_s_vect_type), intent (inout) :: x + real(psb_spk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_sscal_inplace_vect end interface interface psb_mask diff --git a/base/modules/psblas/psb_z_psblas_mod.F90 b/base/modules/psblas/psb_z_psblas_mod.F90 index 35aab6b5..21b59a88 100644 --- a/base/modules/psblas/psb_z_psblas_mod.F90 +++ b/base/modules/psblas/psb_z_psblas_mod.F90 @@ -618,6 +618,14 @@ module psb_z_psblas_mod type(psb_desc_type), intent (in) :: desc_a integer(psb_ipk_), intent(out) :: info end subroutine psb_zscal_vect + subroutine psb_zscal_inplace_vect(x,c,desc_a,info) + import :: psb_desc_type, psb_ipk_, & + & psb_z_vect_type, psb_dpk_ + type(psb_z_vect_type), intent (inout) :: x + complex(psb_dpk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + end subroutine psb_zscal_inplace_vect end interface diff --git a/base/psblas/psb_caxpby.f90 b/base/psblas/psb_caxpby.f90 index 853d4f36..48873e2f 100644 --- a/base/psblas/psb_caxpby.f90 +++ b/base/psblas/psb_caxpby.f90 @@ -827,3 +827,75 @@ subroutine psb_cscal_vect(x,c,z,desc_a,info) return end subroutine psb_cscal_vect +! +! Subroutine: psb_cscal_inplace_vect +! Scale one distributed vector with scalar c, +! +! Z(i) := c*X(i) +! +! Arguments: +! x - type(psb_c_vect_type) The input/output vector X +! c - complex,input The scalar used to scale each component of X +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_cscal_inplace_vect(x,c,desc_a,info) + use psb_base_mod, psb_protect_name => psb_cscal_inplace_vect + implicit none + type(psb_c_vect_type), intent (inout) :: x + complex(psb_spk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=30) :: name, ch_err + + name='psb_cscal_inplace_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ctxt=desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%scal(c) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_cscal_inplace_vect diff --git a/base/psblas/psb_daxpby.f90 b/base/psblas/psb_daxpby.f90 index 5c120258..df699ca0 100644 --- a/base/psblas/psb_daxpby.f90 +++ b/base/psblas/psb_daxpby.f90 @@ -827,3 +827,75 @@ subroutine psb_dscal_vect(x,c,z,desc_a,info) return end subroutine psb_dscal_vect +! +! Subroutine: psb_dscal_inplace_vect +! Scale one distributed vector with scalar c, +! +! Z(i) := c*X(i) +! +! Arguments: +! x - type(psb_d_vect_type) The input/output vector X +! c - real,input The scalar used to scale each component of X +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_dscal_inplace_vect(x,c,desc_a,info) + use psb_base_mod, psb_protect_name => psb_dscal_inplace_vect + implicit none + type(psb_d_vect_type), intent (inout) :: x + real(psb_dpk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=30) :: name, ch_err + + name='psb_dscal_inplace_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ctxt=desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%scal(c) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_dscal_inplace_vect diff --git a/base/psblas/psb_saxpby.f90 b/base/psblas/psb_saxpby.f90 index f144ab86..0077b8c9 100644 --- a/base/psblas/psb_saxpby.f90 +++ b/base/psblas/psb_saxpby.f90 @@ -827,3 +827,75 @@ subroutine psb_sscal_vect(x,c,z,desc_a,info) return end subroutine psb_sscal_vect +! +! Subroutine: psb_sscal_inplace_vect +! Scale one distributed vector with scalar c, +! +! Z(i) := c*X(i) +! +! Arguments: +! x - type(psb_s_vect_type) The input/output vector X +! c - real,input The scalar used to scale each component of X +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_sscal_inplace_vect(x,c,desc_a,info) + use psb_base_mod, psb_protect_name => psb_sscal_inplace_vect + implicit none + type(psb_s_vect_type), intent (inout) :: x + real(psb_spk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=30) :: name, ch_err + + name='psb_sscal_inplace_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ctxt=desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%scal(c) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_sscal_inplace_vect diff --git a/base/psblas/psb_zaxpby.f90 b/base/psblas/psb_zaxpby.f90 index db97c057..cee558ab 100644 --- a/base/psblas/psb_zaxpby.f90 +++ b/base/psblas/psb_zaxpby.f90 @@ -827,3 +827,75 @@ subroutine psb_zscal_vect(x,c,z,desc_a,info) return end subroutine psb_zscal_vect +! +! Subroutine: psb_zscal_inplace_vect +! Scale one distributed vector with scalar c, +! +! Z(i) := c*X(i) +! +! Arguments: +! x - type(psb_z_vect_type) The input/output vector X +! c - complex,input The scalar used to scale each component of X +! desc_a - type(psb_desc_type) The communication descriptor. +! info - integer Return code +! +subroutine psb_zscal_inplace_vect(x,c,desc_a,info) + use psb_base_mod, psb_protect_name => psb_zscal_inplace_vect + implicit none + type(psb_z_vect_type), intent (inout) :: x + complex(psb_dpk_), intent(in) :: c + type(psb_desc_type), intent (in) :: desc_a + integer(psb_ipk_), intent(out) :: info + + ! locals + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me,& + & err_act, iix, jjx, iiy, jjy + integer(psb_lpk_) :: ix, ijx, iy, ijy, m + character(len=30) :: name, ch_err + + name='psb_zscal_inplace_vect' + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + + ctxt=desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -ione) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + if (.not.allocated(x%v)) then + info = psb_err_invalid_vect_state_ + call psb_errpush(info,name) + goto 9999 + endif + + ix = ione + iy = ione + + m = desc_a%get_global_rows() + + ! check vector correctness + call psb_chkvect(m,lone,x%get_nrows(),ix,lone,desc_a,info,iix,jjx) + if(info /= psb_success_) then + info=psb_err_from_subroutine_ + ch_err='psb_chkvect 1' + call psb_errpush(info,name,a_err=ch_err) + goto 9999 + end if + + if(desc_a%get_local_rows() > 0) then + call x%scal(c) + end if + + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end subroutine psb_zscal_inplace_vect diff --git a/krylov/psb_ckrylovsubspace_mod.F90 b/krylov/psb_ckrylovsubspace_mod.F90 index b555a8f2..4c5a4370 100644 --- a/krylov/psb_ckrylovsubspace_mod.F90 +++ b/krylov/psb_ckrylovsubspace_mod.F90 @@ -255,7 +255,7 @@ contains goto 9999 end if scal = cone/kryl%h(i1,i) - call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info) + call psb_gescal(kryl%v(i1),scal,desc_a,info) if (info /= psb_success_) then info=psb_err_from_subroutine_non_ call psb_errpush(info,name) diff --git a/krylov/psb_dkrylovsubspace_mod.F90 b/krylov/psb_dkrylovsubspace_mod.F90 index 7c33c751..0bc1c80d 100644 --- a/krylov/psb_dkrylovsubspace_mod.F90 +++ b/krylov/psb_dkrylovsubspace_mod.F90 @@ -255,7 +255,7 @@ contains goto 9999 end if scal = done/kryl%h(i1,i) - call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info) + call psb_gescal(kryl%v(i1),scal,desc_a,info) if (info /= psb_success_) then info=psb_err_from_subroutine_non_ call psb_errpush(info,name) diff --git a/krylov/psb_skrylovsubspace_mod.F90 b/krylov/psb_skrylovsubspace_mod.F90 index cacc2a86..93bbc3a4 100644 --- a/krylov/psb_skrylovsubspace_mod.F90 +++ b/krylov/psb_skrylovsubspace_mod.F90 @@ -255,7 +255,7 @@ contains goto 9999 end if scal = sone/kryl%h(i1,i) - call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info) + call psb_gescal(kryl%v(i1),scal,desc_a,info) if (info /= psb_success_) then info=psb_err_from_subroutine_non_ call psb_errpush(info,name) diff --git a/krylov/psb_zkrylovsubspace_mod.F90 b/krylov/psb_zkrylovsubspace_mod.F90 index cd01e9ab..3bad9aea 100644 --- a/krylov/psb_zkrylovsubspace_mod.F90 +++ b/krylov/psb_zkrylovsubspace_mod.F90 @@ -255,7 +255,7 @@ contains goto 9999 end if scal = zone/kryl%h(i1,i) - call psb_gescal(kryl%v(i1),scal,kryl%v(i1),desc_a,info) + call psb_gescal(kryl%v(i1),scal,desc_a,info) if (info /= psb_success_) then info=psb_err_from_subroutine_non_ call psb_errpush(info,name)