From 1ee1b8334195cd72cdfa47090dc3334dc338759a Mon Sep 17 00:00:00 2001 From: Fabio Durastante Date: Thu, 19 Mar 2026 14:58:00 +0100 Subject: [PATCH] Added routine to extract single element from sparse matrix --- base/modules/tools/psb_c_tools_mod.F90 | 8 +++ base/modules/tools/psb_d_tools_mod.F90 | 8 +++ base/modules/tools/psb_s_tools_mod.F90 | 8 +++ base/modules/tools/psb_z_tools_mod.F90 | 8 +++ base/tools/psb_cgetelem.f90 | 89 ++++++++++++++++++++++++++ base/tools/psb_dgetelem.f90 | 89 ++++++++++++++++++++++++++ base/tools/psb_sgetelem.f90 | 89 ++++++++++++++++++++++++++ base/tools/psb_zgetelem.f90 | 89 ++++++++++++++++++++++++++ cbind/base/psb_c_cbase.h | 1 + cbind/base/psb_c_dbase.h | 2 + cbind/base/psb_c_sbase.h | 2 + cbind/base/psb_c_tools_cbind_mod.F90 | 69 ++++++++++---------- cbind/base/psb_c_zbase.h | 2 + cbind/base/psb_d_tools_cbind_mod.F90 | 69 ++++++++++---------- cbind/base/psb_s_tools_cbind_mod.F90 | 69 ++++++++++---------- cbind/base/psb_z_tools_cbind_mod.F90 | 69 ++++++++++---------- 16 files changed, 535 insertions(+), 136 deletions(-) diff --git a/base/modules/tools/psb_c_tools_mod.F90 b/base/modules/tools/psb_c_tools_mod.F90 index 4dc0ee52..148ddf59 100644 --- a/base/modules/tools/psb_c_tools_mod.F90 +++ b/base/modules/tools/psb_c_tools_mod.F90 @@ -444,6 +444,14 @@ Module psb_c_tools_mod integer(psb_ipk_), intent(out) :: info complex(psb_spk_) :: res end function + function psb_c_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + import + type(psb_cspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: rowindex, colindex + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: res + end function end interface interface psb_remap diff --git a/base/modules/tools/psb_d_tools_mod.F90 b/base/modules/tools/psb_d_tools_mod.F90 index e4e8d639..97f70fc1 100644 --- a/base/modules/tools/psb_d_tools_mod.F90 +++ b/base/modules/tools/psb_d_tools_mod.F90 @@ -444,6 +444,14 @@ Module psb_d_tools_mod integer(psb_ipk_), intent(out) :: info real(psb_dpk_) :: res end function + function psb_d_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + import + type(psb_dspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: rowindex, colindex + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: res + end function end interface interface psb_remap diff --git a/base/modules/tools/psb_s_tools_mod.F90 b/base/modules/tools/psb_s_tools_mod.F90 index d9dd5977..c87607bc 100644 --- a/base/modules/tools/psb_s_tools_mod.F90 +++ b/base/modules/tools/psb_s_tools_mod.F90 @@ -444,6 +444,14 @@ Module psb_s_tools_mod integer(psb_ipk_), intent(out) :: info real(psb_spk_) :: res end function + function psb_s_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + import + type(psb_sspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: rowindex, colindex + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: res + end function end interface interface psb_remap diff --git a/base/modules/tools/psb_z_tools_mod.F90 b/base/modules/tools/psb_z_tools_mod.F90 index cdb9f446..8a6c2d34 100644 --- a/base/modules/tools/psb_z_tools_mod.F90 +++ b/base/modules/tools/psb_z_tools_mod.F90 @@ -444,6 +444,14 @@ Module psb_z_tools_mod integer(psb_ipk_), intent(out) :: info complex(psb_dpk_) :: res end function + function psb_z_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + import + type(psb_zspmat_type), intent(inout) :: a + integer(psb_lpk_), intent(in) :: rowindex, colindex + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: res + end function end interface interface psb_remap diff --git a/base/tools/psb_cgetelem.f90 b/base/tools/psb_cgetelem.f90 index ae90b2b0..952ae251 100644 --- a/base/tools/psb_cgetelem.f90 +++ b/base/tools/psb_cgetelem.f90 @@ -108,3 +108,92 @@ function psb_c_getelem(x,index,desc_a,info) result(res) end function +! Function: psb_c_getmatelem +! Extract entries from a sparse matrix. Note: the row and column indices in index +! are assumed to be in global numbering and are converted on the fly. +! +! Arguments: +! a - type(psb_cspmat_type) The source matrix +! desc_a - type(psb_desc_type). The communication descriptor. +! rowindex - integer. Row index of x of the value to extract +! colindex - integer. Column index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_c_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_c_getmatelem + use psi_mod + implicit none + + type(psb_cspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: rowindex, colindex + integer(psb_ipk_), intent(out) :: info + complex(psb_spk_) :: res + + !locals + integer(psb_ipk_) :: localrowindex(1), localcolindex(1), jmin, jmax, imin, imax + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: growindex(1), gcolindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + integer(psb_ipk_), allocatable, dimension(:) :: ia, ja + integer(psb_ipk_) :: nz + complex(psb_spk_), allocatable, dimension(:) :: val + character(len=20) :: name + logical, parameter :: debug = .false. + + growindex(1) = rowindex + gcolindex(1) = colindex + res = czero + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_c_getmatelem' + + 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 + + call desc_a%indxmap%g2l(growindex,localrowindex,info,owned=.false.) + call desc_a%indxmap%g2l(gcolindex,localcolindex,info,owned=.false.) + imin = localrowindex(1) + imax = localrowindex(1) + jmin = localcolindex(1) + jmax = localcolindex(1) + if(debug.and.(localrowindex(1) < 1 .or. localcolindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global row index is ", & + growindex,"Local row index is ",localrowindex + write(*,*)"Process ",me," owns ",desc_a%get_local_cols()," cols"," Global col index is ", & + gcolindex,"Local col index is ",localcolindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localrowindex(1) < 1 .or. localcolindex(1) < 1) then + res = czero + else + call a%csget(imin, imax, nz, ia, ja, val, info, jmin=jmin, jmax=jmax) + res = val(1) + end if + 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 6df8229a..805204b0 100644 --- a/base/tools/psb_dgetelem.f90 +++ b/base/tools/psb_dgetelem.f90 @@ -108,3 +108,92 @@ function psb_d_getelem(x,index,desc_a,info) result(res) end function +! Function: psb_d_getmatelem +! Extract entries from a sparse matrix. Note: the row and column indices in index +! are assumed to be in global numbering and are converted on the fly. +! +! Arguments: +! a - type(psb_dspmat_type) The source matrix +! desc_a - type(psb_desc_type). The communication descriptor. +! rowindex - integer. Row index of x of the value to extract +! colindex - integer. Column index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_d_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_d_getmatelem + use psi_mod + implicit none + + type(psb_dspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: rowindex, colindex + integer(psb_ipk_), intent(out) :: info + real(psb_dpk_) :: res + + !locals + integer(psb_ipk_) :: localrowindex(1), localcolindex(1), jmin, jmax, imin, imax + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: growindex(1), gcolindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + integer(psb_ipk_), allocatable, dimension(:) :: ia, ja + integer(psb_ipk_) :: nz + real(psb_dpk_), allocatable, dimension(:) :: val + character(len=20) :: name + logical, parameter :: debug = .false. + + growindex(1) = rowindex + gcolindex(1) = colindex + res = dzero + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_d_getmatelem' + + 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 + + call desc_a%indxmap%g2l(growindex,localrowindex,info,owned=.false.) + call desc_a%indxmap%g2l(gcolindex,localcolindex,info,owned=.false.) + imin = localrowindex(1) + imax = localrowindex(1) + jmin = localcolindex(1) + jmax = localcolindex(1) + if(debug.and.(localrowindex(1) < 1 .or. localcolindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global row index is ", & + growindex,"Local row index is ",localrowindex + write(*,*)"Process ",me," owns ",desc_a%get_local_cols()," cols"," Global col index is ", & + gcolindex,"Local col index is ",localcolindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localrowindex(1) < 1 .or. localcolindex(1) < 1) then + res = dzero + else + call a%csget(imin, imax, nz, ia, ja, val, info, jmin=jmin, jmax=jmax) + res = val(1) + end if + 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 118ee31b..73ab33ef 100644 --- a/base/tools/psb_sgetelem.f90 +++ b/base/tools/psb_sgetelem.f90 @@ -108,3 +108,92 @@ function psb_s_getelem(x,index,desc_a,info) result(res) end function +! Function: psb_s_getmatelem +! Extract entries from a sparse matrix. Note: the row and column indices in index +! are assumed to be in global numbering and are converted on the fly. +! +! Arguments: +! a - type(psb_sspmat_type) The source matrix +! desc_a - type(psb_desc_type). The communication descriptor. +! rowindex - integer. Row index of x of the value to extract +! colindex - integer. Column index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_s_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_s_getmatelem + use psi_mod + implicit none + + type(psb_sspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: rowindex, colindex + integer(psb_ipk_), intent(out) :: info + real(psb_spk_) :: res + + !locals + integer(psb_ipk_) :: localrowindex(1), localcolindex(1), jmin, jmax, imin, imax + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: growindex(1), gcolindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + integer(psb_ipk_), allocatable, dimension(:) :: ia, ja + integer(psb_ipk_) :: nz + real(psb_spk_), allocatable, dimension(:) :: val + character(len=20) :: name + logical, parameter :: debug = .false. + + growindex(1) = rowindex + gcolindex(1) = colindex + res = szero + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_s_getmatelem' + + 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 + + call desc_a%indxmap%g2l(growindex,localrowindex,info,owned=.false.) + call desc_a%indxmap%g2l(gcolindex,localcolindex,info,owned=.false.) + imin = localrowindex(1) + imax = localrowindex(1) + jmin = localcolindex(1) + jmax = localcolindex(1) + if(debug.and.(localrowindex(1) < 1 .or. localcolindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global row index is ", & + growindex,"Local row index is ",localrowindex + write(*,*)"Process ",me," owns ",desc_a%get_local_cols()," cols"," Global col index is ", & + gcolindex,"Local col index is ",localcolindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localrowindex(1) < 1 .or. localcolindex(1) < 1) then + res = szero + else + call a%csget(imin, imax, nz, ia, ja, val, info, jmin=jmin, jmax=jmax) + res = val(1) + end if + 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 45757cef..a4cb114b 100644 --- a/base/tools/psb_zgetelem.f90 +++ b/base/tools/psb_zgetelem.f90 @@ -108,3 +108,92 @@ function psb_z_getelem(x,index,desc_a,info) result(res) end function +! Function: psb_z_getmatelem +! Extract entries from a sparse matrix. Note: the row and column indices in index +! are assumed to be in global numbering and are converted on the fly. +! +! Arguments: +! a - type(psb_zspmat_type) The source matrix +! desc_a - type(psb_desc_type). The communication descriptor. +! rowindex - integer. Row index of x of the value to extract +! colindex - integer. Column index of x of the value to extract +! iam - integer. Index of the process requesting the value +! info - integer. return code + + +function psb_z_getmatelem(a,rowindex,colindex,desc_a,info) result(res) + use psb_base_mod, psb_protect_name => psb_z_getmatelem + use psi_mod + implicit none + + type(psb_zspmat_type), intent(inout) :: a + type(psb_desc_type), intent(inout) :: desc_a + integer(psb_lpk_), intent(in) :: rowindex, colindex + integer(psb_ipk_), intent(out) :: info + complex(psb_dpk_) :: res + + !locals + integer(psb_ipk_) :: localrowindex(1), localcolindex(1), jmin, jmax, imin, imax + type(psb_ctxt_type) :: ctxt + integer(psb_ipk_) :: np, me, err_act + integer(psb_lpk_) :: growindex(1), gcolindex(1) + integer(psb_lpk_), allocatable :: myidx(:),mylocal(:) + integer(psb_ipk_), allocatable, dimension(:) :: ia, ja + integer(psb_ipk_) :: nz + complex(psb_dpk_), allocatable, dimension(:) :: val + character(len=20) :: name + logical, parameter :: debug = .false. + + growindex(1) = rowindex + gcolindex(1) = colindex + res = zzero + if (psb_errstatus_fatal()) return + info=psb_success_ + call psb_erractionsave(err_act) + name = 'psb_z_getmatelem' + + 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 + + call desc_a%indxmap%g2l(growindex,localrowindex,info,owned=.false.) + call desc_a%indxmap%g2l(gcolindex,localcolindex,info,owned=.false.) + imin = localrowindex(1) + imax = localrowindex(1) + jmin = localcolindex(1) + jmax = localcolindex(1) + if(debug.and.(localrowindex(1) < 1 .or. localcolindex(1) < 1)) then + write(*,*)"Process ",me," owns ",desc_a%get_local_rows()," rows"," Global row index is ", & + growindex,"Local row index is ",localrowindex + write(*,*)"Process ",me," owns ",desc_a%get_local_cols()," cols"," Global col index is ", & + gcolindex,"Local col index is ",localcolindex + myidx = desc_a%get_global_indices(owned=.false.) + mylocal = desc_a%get_global_indices(owned=.true.) + write(*,*)"My (local+halo) indexes are: ",myidx + write(*,*)"My (local) indexes are: ",mylocal + end if + if ( localrowindex(1) < 1 .or. localcolindex(1) < 1) then + res = zzero + else + call a%csget(imin, imax, nz, ia, ja, val, info, jmin=jmin, jmax=jmax) + res = val(1) + end if + call psb_erractionrestore(err_act) + return + +9999 call psb_error_handler(ctxt,err_act) + + return + +end function diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index 0dd426d7..45b6c825 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -39,6 +39,7 @@ psb_i_t psb_c_cgeasb_options_format(psb_c_cvector *xh, psb_c_descriptor *cdh, psb_i_t psb_c_cgefree(psb_c_cvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_cgereinit(psb_c_cvector *xh, psb_c_descriptor *cdh, bool clear); psb_c_t psb_c_cgetelem(psb_c_cvector *xh,psb_l_t index,psb_c_descriptor *cd); +psb_c_t psb_c_cmatgetelem(psb_c_cspmat *ah,psb_l_t rowindex,psb_l_t colindex,psb_c_descriptor *cdh); /* sparse matrices*/ psb_c_cspmat* psb_c_new_cspmat(); diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index 97ef408f..bf0be8ba 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -39,6 +39,8 @@ psb_i_t psb_c_dgeasb_options_format(psb_c_dvector *xh, psb_c_descriptor *cdh, psb_i_t psb_c_dgefree(psb_c_dvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_dgereinit(psb_c_dvector *xh, psb_c_descriptor *cdh, bool clear); psb_d_t psb_c_dgetelem(psb_c_dvector *xh,psb_l_t index,psb_c_descriptor *cd); +psb_d_t psb_c_dmatgetelem(psb_c_dspmat *ah,psb_l_t rowindex,psb_l_t colindex,psb_c_descriptor *cdh); + /* sparse matrices*/ psb_c_dspmat* psb_c_new_dspmat(); diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index 1e1895ba..fa501a50 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -39,6 +39,8 @@ psb_i_t psb_c_sgeasb_options_format(psb_c_svector *xh, psb_c_descriptor *cdh, psb_i_t psb_c_sgefree(psb_c_svector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_sgereinit(psb_c_svector *xh, psb_c_descriptor *cdh, bool clear); psb_s_t psb_c_sgetelem(psb_c_svector *xh,psb_l_t index,psb_c_descriptor *cd); +psb_s_t psb_c_smatgetelem(psb_c_sspmat *ah,psb_l_t rowindex,psb_l_t colindex,psb_c_descriptor *cdh); + /* sparse matrices*/ psb_c_sspmat* psb_c_new_sspmat(); diff --git a/cbind/base/psb_c_tools_cbind_mod.F90 b/cbind/base/psb_c_tools_cbind_mod.F90 index 5cf3478e..0163f544 100644 --- a/cbind/base/psb_c_tools_cbind_mod.F90 +++ b/cbind/base/psb_c_tools_cbind_mod.F90 @@ -253,40 +253,6 @@ contains end function psb_c_cgefree - function psb_c_cgereinit(xh,cdh,clear) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: clear - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - logical :: fclear - - res = -1 - - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - fclear = clear - call xp%reinit(info, clear=fclear) - res = min(0,info) - - return - end function psb_c_cgereinit - - function psb_c_cgeins(nz,irw,val,xh,cdh) bind(c) result(res) implicit none @@ -688,4 +654,39 @@ contains end function psb_c_cgetelem + function psb_c_cmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) + implicit none + + type(psb_c_cspmat) :: ah + integer(psb_c_lpk_), value :: rowindex, colindex + type(psb_c_descriptor) :: cdh + complex(c_float_complex) :: res + + type(psb_cspmat_type), pointer :: ap + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + res = psb_getelem(ap,rowindex,colindex,descp,info) + else + res = psb_getelem(ap,rowindex+(1-ixb),colindex+(1-ixb),descp,info) + end if + + return + + end function psb_c_cmatgetelem + end module psb_c_tools_cbind_mod diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index 2e4f01c4..fed51efb 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -39,6 +39,8 @@ psb_i_t psb_c_zgeasb_options_format(psb_c_zvector *xh, psb_c_descriptor *cdh, psb_i_t psb_c_zgefree(psb_c_zvector *xh, psb_c_descriptor *cdh); psb_i_t psb_c_zgereinit(psb_c_zvector *xh, psb_c_descriptor *cdh, bool clear); psb_z_t psb_c_zgetelem(psb_c_zvector *xh,psb_l_t index,psb_c_descriptor *cd); +psb_z_t psb_c_zmatgetelem(psb_c_zspmat *ah,psb_l_t rowindex,psb_l_t colindex,psb_c_descriptor *cdh); + /* sparse matrices*/ psb_c_zspmat* psb_c_new_zspmat(); diff --git a/cbind/base/psb_d_tools_cbind_mod.F90 b/cbind/base/psb_d_tools_cbind_mod.F90 index 1b4bb40e..f8037773 100644 --- a/cbind/base/psb_d_tools_cbind_mod.F90 +++ b/cbind/base/psb_d_tools_cbind_mod.F90 @@ -253,40 +253,6 @@ contains end function psb_c_dgefree - function psb_c_dgereinit(xh,cdh,clear) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: clear - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - logical :: fclear - - res = -1 - - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - fclear = clear - call xp%reinit(info, clear=fclear) - res = min(0,info) - - return - end function psb_c_dgereinit - - function psb_c_dgeins(nz,irw,val,xh,cdh) bind(c) result(res) implicit none @@ -698,4 +664,39 @@ contains end function psb_c_dgetelem + function psb_c_dmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) + implicit none + + type(psb_c_dspmat) :: ah + integer(psb_c_lpk_), value :: rowindex, colindex + type(psb_c_descriptor) :: cdh + real(c_double) :: res + + type(psb_dspmat_type), pointer :: ap + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + res = psb_getelem(ap,rowindex,colindex,descp,info) + else + res = psb_getelem(ap,rowindex+(1-ixb),colindex+(1-ixb),descp,info) + end if + + return + + end function psb_c_dmatgetelem + end module psb_d_tools_cbind_mod diff --git a/cbind/base/psb_s_tools_cbind_mod.F90 b/cbind/base/psb_s_tools_cbind_mod.F90 index 3f5334a7..43ac426e 100644 --- a/cbind/base/psb_s_tools_cbind_mod.F90 +++ b/cbind/base/psb_s_tools_cbind_mod.F90 @@ -253,40 +253,6 @@ contains end function psb_c_sgefree - function psb_c_sgereinit(xh,cdh,clear) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: clear - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - logical :: fclear - - res = -1 - - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - fclear = clear - call xp%reinit(info, clear=fclear) - res = min(0,info) - - return - end function psb_c_sgereinit - - function psb_c_sgeins(nz,irw,val,xh,cdh) bind(c) result(res) implicit none @@ -698,4 +664,39 @@ contains end function psb_c_sgetelem + function psb_c_smatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) + implicit none + + type(psb_c_sspmat) :: ah + integer(psb_c_lpk_), value :: rowindex, colindex + type(psb_c_descriptor) :: cdh + real(c_float) :: res + + type(psb_sspmat_type), pointer :: ap + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + res = psb_getelem(ap,rowindex,colindex,descp,info) + else + res = psb_getelem(ap,rowindex+(1-ixb),colindex+(1-ixb),descp,info) + end if + + return + + end function psb_c_smatgetelem + end module psb_s_tools_cbind_mod diff --git a/cbind/base/psb_z_tools_cbind_mod.F90 b/cbind/base/psb_z_tools_cbind_mod.F90 index b4693a4c..a4bda8c9 100644 --- a/cbind/base/psb_z_tools_cbind_mod.F90 +++ b/cbind/base/psb_z_tools_cbind_mod.F90 @@ -253,40 +253,6 @@ contains end function psb_c_zgefree - function psb_c_zgereinit(xh,cdh,clear) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: clear - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - logical :: fclear - - res = -1 - - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - fclear = clear - call xp%reinit(info, clear=fclear) - res = min(0,info) - - return - end function psb_c_zgereinit - - function psb_c_zgeins(nz,irw,val,xh,cdh) bind(c) result(res) implicit none @@ -688,4 +654,39 @@ contains end function psb_c_zgetelem + function psb_c_zmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) + implicit none + + type(psb_c_zspmat) :: ah + integer(psb_c_lpk_), value :: rowindex, colindex + type(psb_c_descriptor) :: cdh + complex(c_double_complex) :: res + + type(psb_zspmat_type), pointer :: ap + type(psb_desc_type), pointer :: descp + integer(psb_c_ipk_) :: info, ixb + + res = -1 + if (c_associated(cdh%item)) then + call c_f_pointer(cdh%item,descp) + else + return + end if + if (c_associated(ah%item)) then + call c_f_pointer(ah%item,ap) + else + return + end if + + ixb = psb_c_get_index_base() + if (ixb == 1) then + res = psb_getelem(ap,rowindex,colindex,descp,info) + else + res = psb_getelem(ap,rowindex+(1-ixb),colindex+(1-ixb),descp,info) + end if + + return + + end function psb_c_zmatgetelem + end module psb_z_tools_cbind_mod