From 00df32c581ea4f893f9d16c8d265f5862053528a Mon Sep 17 00:00:00 2001 From: Cirdans-Home Date: Thu, 22 Jun 2023 15:20:33 +0200 Subject: [PATCH] Added getelem_vec implementation --- base/modules/auxil/psb_c_realloc_mod.F90 | 2 +- base/modules/auxil/psb_d_realloc_mod.F90 | 2 +- base/modules/auxil/psb_e_realloc_mod.F90 | 2 +- base/modules/auxil/psb_i2_realloc_mod.F90 | 2 +- base/modules/auxil/psb_m_realloc_mod.F90 | 2 +- base/modules/auxil/psb_s_realloc_mod.F90 | 2 +- base/modules/auxil/psb_z_realloc_mod.F90 | 2 +- base/modules/tools/psb_c_tools_mod.F90 | 14 +++-- base/modules/tools/psb_d_tools_mod.F90 | 14 +++-- base/modules/tools/psb_i_tools_mod.F90 | 2 +- base/modules/tools/psb_l_tools_mod.F90 | 2 +- base/modules/tools/psb_s_tools_mod.F90 | 14 +++-- base/modules/tools/psb_z_tools_mod.F90 | 14 +++-- base/tools/psb_cgetelem.f90 | 66 +++++++++++++++++++++++ base/tools/psb_dgetelem.f90 | 66 +++++++++++++++++++++++ base/tools/psb_sgetelem.f90 | 66 +++++++++++++++++++++++ base/tools/psb_zgetelem.f90 | 66 +++++++++++++++++++++++ 17 files changed, 317 insertions(+), 21 deletions(-) diff --git a/base/modules/auxil/psb_c_realloc_mod.F90 b/base/modules/auxil/psb_c_realloc_mod.F90 index 231fde3f..4cea4683 100644 --- a/base/modules/auxil/psb_c_realloc_mod.F90 +++ b/base/modules/auxil/psb_c_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz) + isz = max(len,1,isz+addsz)) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_d_realloc_mod.F90 b/base/modules/auxil/psb_d_realloc_mod.F90 index cb48fc66..f30435fe 100644 --- a/base/modules/auxil/psb_d_realloc_mod.F90 +++ b/base/modules/auxil/psb_d_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz) + isz = max(len,1,isz+addsz)) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_e_realloc_mod.F90 b/base/modules/auxil/psb_e_realloc_mod.F90 index 1bf45e30..0cf321f4 100644 --- a/base/modules/auxil/psb_e_realloc_mod.F90 +++ b/base/modules/auxil/psb_e_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz) + isz = max(len,1,isz+addsz)) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_i2_realloc_mod.F90 b/base/modules/auxil/psb_i2_realloc_mod.F90 index cbf4d58a..cebd8695 100644 --- a/base/modules/auxil/psb_i2_realloc_mod.F90 +++ b/base/modules/auxil/psb_i2_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz) + isz = max(len,1,isz+addsz)) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_m_realloc_mod.F90 b/base/modules/auxil/psb_m_realloc_mod.F90 index e0e486ec..42b981b4 100644 --- a/base/modules/auxil/psb_m_realloc_mod.F90 +++ b/base/modules/auxil/psb_m_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz) + isz = max(len,1,isz+addsz)) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_s_realloc_mod.F90 b/base/modules/auxil/psb_s_realloc_mod.F90 index 676caf31..8d2d5af1 100644 --- a/base/modules/auxil/psb_s_realloc_mod.F90 +++ b/base/modules/auxil/psb_s_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz) + isz = max(len,1,isz+addsz)) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/auxil/psb_z_realloc_mod.F90 b/base/modules/auxil/psb_z_realloc_mod.F90 index 652d3c99..e81b767a 100644 --- a/base/modules/auxil/psb_z_realloc_mod.F90 +++ b/base/modules/auxil/psb_z_realloc_mod.F90 @@ -1017,7 +1017,7 @@ Contains if (present(newsz)) then isz = max(len+1,1,newsz) else if (present(addsz)) then - isz = max(len,1,isz+addsz) + isz = max(len,1,isz+addsz)) else isz = max(len,1,int(1.25*isz)) endif diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index 2de8f906..fe2e0cd8 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -171,7 +171,7 @@ Module psb_c_tools_mod logical, intent(in), optional :: local end subroutine psb_cins_multivect end interface - + interface psb_cdbldext Subroutine psb_ccdbldext(a,desc_a,novr,desc_ov,info,extype) import @@ -272,7 +272,7 @@ Module psb_c_tools_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lc_remote_mat end interface psb_remote_mat - + interface psb_spfree subroutine psb_cspfree(a, desc_a,info) import @@ -440,6 +440,14 @@ Module psb_c_tools_mod integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: res end function + function psb_c_getelem_vec(x,index,desc_a,info) result(res) + import + type(psb_c_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in), dimension(:) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), allocatable, dimension(:) :: res + end function end interface interface psb_remap @@ -453,7 +461,7 @@ Module psb_c_tools_mod type(psb_cspmat_type), intent(inout) :: a_in type(psb_cspmat_type), intent(out) :: a_out type(psb_desc_type), intent(out) :: desc_out - integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), intent(out) :: ipd integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_c_remap diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index 30e45d53..8603955d 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -171,7 +171,7 @@ Module psb_d_tools_mod logical, intent(in), optional :: local end subroutine psb_dins_multivect end interface - + interface psb_cdbldext Subroutine psb_dcdbldext(a,desc_a,novr,desc_ov,info,extype) import @@ -272,7 +272,7 @@ Module psb_d_tools_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ld_remote_mat end interface psb_remote_mat - + interface psb_spfree subroutine psb_dspfree(a, desc_a,info) import @@ -440,6 +440,14 @@ Module psb_d_tools_mod integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res end function + function psb_d_getelem_vec(x,index,desc_a,info) result(res) + import + type(psb_d_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in), dimension(:) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), allocatable, dimension(:) :: res + end function end interface interface psb_remap @@ -453,7 +461,7 @@ Module psb_d_tools_mod type(psb_dspmat_type), intent(inout) :: a_in type(psb_dspmat_type), intent(out) :: a_out type(psb_desc_type), intent(out) :: desc_out - integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), intent(out) :: ipd integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_d_remap diff --git a/base/modules/tools/psb_i_tools_mod.F90 b/base/modules/tools/psb_i_tools_mod.F90 index 1c207fac..afdec48f 100644 --- a/base/modules/tools/psb_i_tools_mod.F90 +++ b/base/modules/tools/psb_i_tools_mod.F90 @@ -170,5 +170,5 @@ Module psb_i_tools_mod logical, intent(in), optional :: local end subroutine psb_iins_multivect end interface - + end module psb_i_tools_mod diff --git a/base/modules/tools/psb_l_tools_mod.F90 b/base/modules/tools/psb_l_tools_mod.F90 index 058403d6..7f38117c 100644 --- a/base/modules/tools/psb_l_tools_mod.F90 +++ b/base/modules/tools/psb_l_tools_mod.F90 @@ -170,5 +170,5 @@ Module psb_l_tools_mod logical, intent(in), optional :: local end subroutine psb_lins_multivect end interface - + end module psb_l_tools_mod diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index 5d2f8d00..99b9aa4e 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -171,7 +171,7 @@ Module psb_s_tools_mod logical, intent(in), optional :: local end subroutine psb_sins_multivect end interface - + interface psb_cdbldext Subroutine psb_scdbldext(a,desc_a,novr,desc_ov,info,extype) import @@ -272,7 +272,7 @@ Module psb_s_tools_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_ls_remote_mat end interface psb_remote_mat - + interface psb_spfree subroutine psb_sspfree(a, desc_a,info) import @@ -440,6 +440,14 @@ Module psb_s_tools_mod integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res end function + function psb_s_getelem_vec(x,index,desc_a,info) result(res) + import + type(psb_s_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in), dimension(:) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), allocatable, dimension(:) :: res + end function end interface interface psb_remap @@ -453,7 +461,7 @@ Module psb_s_tools_mod type(psb_sspmat_type), intent(inout) :: a_in type(psb_sspmat_type), intent(out) :: a_out type(psb_desc_type), intent(out) :: desc_out - integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), intent(out) :: ipd integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_s_remap diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index 9d6bd77b..e983fa6b 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -171,7 +171,7 @@ Module psb_z_tools_mod logical, intent(in), optional :: local end subroutine psb_zins_multivect end interface - + interface psb_cdbldext Subroutine psb_zcdbldext(a,desc_a,novr,desc_ov,info,extype) import @@ -272,7 +272,7 @@ Module psb_z_tools_mod integer(psb_ipk_), intent(out) :: info end subroutine psb_lz_remote_mat end interface psb_remote_mat - + interface psb_spfree subroutine psb_zspfree(a, desc_a,info) import @@ -440,6 +440,14 @@ Module psb_z_tools_mod integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: res end function + function psb_z_getelem_vec(x,index,desc_a,info) result(res) + import + type(psb_z_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in), dimension(:) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), allocatable, dimension(:) :: res + end function end interface interface psb_remap @@ -453,7 +461,7 @@ Module psb_z_tools_mod type(psb_zspmat_type), intent(inout) :: a_in type(psb_zspmat_type), intent(out) :: a_out type(psb_desc_type), intent(out) :: desc_out - integer(psb_ipk_), intent(out) :: ipd + integer(psb_ipk_), intent(out) :: ipd integer(psb_ipk_), allocatable, intent(out) :: isrc(:), nrsrc(:), naggr(:) integer(psb_ipk_), intent(out) :: info end subroutine psb_z_remap diff --git a/base/tools/psb_cgetelem.f90 b/base/tools/psb_cgetelem.f90 index 3c4151c9..b1ece4d5 100644 --- a/base/tools/psb_cgetelem.f90 +++ b/base/tools/psb_cgetelem.f90 @@ -108,3 +108,69 @@ function psb_c_getelem(x,index,desc_a,info) result(res) end function +function psb_c_getelem_vec(x,index,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_c_getelem_vec + use psi_mod + implicit none + + type(psb_c_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in), dimension(:) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_), allocatable, dimension(:) :: res + ! Local Variables + integer(psb_ipk_) :: nindex, i + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_), allocatable, dimension(:) :: localindex + integer(psb_lpk_) :: gindex(1) + type(psb_ctxt_type) :: ctxt + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_c_getelem_vec' + + nindex = size(index) + + if (.not.allocated(res)) then + allocate(res(nindex),stat=info) + end if + res = czero + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ctxt = desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + do i = 1,nindex + gindex(1) = index(i) + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.true.) + if ( localindex(1) > 1) then + res(i) = x%get_entry(localindex(1)) + end if + end do + + call psb_sum(ctxt,res,root=-1) + + + ! Error handling and closing + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end function + diff --git a/base/tools/psb_dgetelem.f90 b/base/tools/psb_dgetelem.f90 index 38d398aa..d88bf4d0 100644 --- a/base/tools/psb_dgetelem.f90 +++ b/base/tools/psb_dgetelem.f90 @@ -108,3 +108,69 @@ function psb_d_getelem(x,index,desc_a,info) result(res) end function +function psb_d_getelem_vec(x,index,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_d_getelem_vec + use psi_mod + implicit none + + type(psb_d_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in), dimension(:) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_), allocatable, dimension(:) :: res + ! Local Variables + integer(psb_ipk_) :: nindex, i + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_), allocatable, dimension(:) :: localindex + integer(psb_lpk_) :: gindex(1) + type(psb_ctxt_type) :: ctxt + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_d_getelem_vec' + + nindex = size(index) + + if (.not.allocated(res)) then + allocate(res(nindex),stat=info) + end if + res = dzero + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ctxt = desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + do i = 1,nindex + gindex(1) = index(i) + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.true.) + if ( localindex(1) > 1) then + res(i) = x%get_entry(localindex(1)) + end if + end do + + call psb_sum(ctxt,res,root=-1) + + + ! Error handling and closing + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end function + diff --git a/base/tools/psb_sgetelem.f90 b/base/tools/psb_sgetelem.f90 index 723a2f7d..d93ff730 100644 --- a/base/tools/psb_sgetelem.f90 +++ b/base/tools/psb_sgetelem.f90 @@ -108,3 +108,69 @@ function psb_s_getelem(x,index,desc_a,info) result(res) end function +function psb_s_getelem_vec(x,index,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_s_getelem_vec + use psi_mod + implicit none + + type(psb_s_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in), dimension(:) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_), allocatable, dimension(:) :: res + ! Local Variables + integer(psb_ipk_) :: nindex, i + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_), allocatable, dimension(:) :: localindex + integer(psb_lpk_) :: gindex(1) + type(psb_ctxt_type) :: ctxt + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_s_getelem_vec' + + nindex = size(index) + + if (.not.allocated(res)) then + allocate(res(nindex),stat=info) + end if + res = szero + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ctxt = desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + do i = 1,nindex + gindex(1) = index(i) + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.true.) + if ( localindex(1) > 1) then + res(i) = x%get_entry(localindex(1)) + end if + end do + + call psb_sum(ctxt,res,root=-1) + + + ! Error handling and closing + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end function + diff --git a/base/tools/psb_zgetelem.f90 b/base/tools/psb_zgetelem.f90 index ac130e82..7e01adeb 100644 --- a/base/tools/psb_zgetelem.f90 +++ b/base/tools/psb_zgetelem.f90 @@ -108,3 +108,69 @@ function psb_z_getelem(x,index,desc_a,info) result(res) end function +function psb_z_getelem_vec(x,index,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_z_getelem_vec + use psi_mod + implicit none + + type(psb_z_vect_type), intent(inout) :: x + integer(psb_lpk_), intent(in), dimension(:) :: index + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_), allocatable, dimension(:) :: res + ! Local Variables + integer(psb_ipk_) :: nindex, i + integer(psb_ipk_) :: np, me, err_act + integer(psb_ipk_), allocatable, dimension(:) :: localindex + integer(psb_lpk_) :: gindex(1) + type(psb_ctxt_type) :: ctxt + character(len=20) :: name + + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_z_getelem_vec' + + nindex = size(index) + + if (.not.allocated(res)) then + allocate(res(nindex),stat=info) + end if + res = zzero + + if (.not.desc_a%is_ok()) then + info = psb_err_invalid_cd_state_ + call psb_errpush(info,name) + goto 9999 + end if + + ctxt = desc_a%get_context() + + call psb_info(ctxt, me, np) + if (np == -1) then + info = psb_err_context_error_ + call psb_errpush(info,name) + goto 9999 + endif + + do i = 1,nindex + gindex(1) = index(i) + call desc_a%indxmap%g2l(gindex,localindex,info,owned=.true.) + if ( localindex(1) > 1) then + res(i) = x%get_entry(localindex(1)) + end if + end do + + call psb_sum(ctxt,res,root=-1) + + + ! Error handling and closing + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end function +