diff --git a/base/modules/serial/psb_c_base_vect_mod.F90 b/base/modules/serial/psb_c_base_vect_mod.F90 index cd970162..e1058c1f 100644 --- a/base/modules/serial/psb_c_base_vect_mod.F90 +++ b/base/modules/serial/psb_c_base_vect_mod.F90 @@ -157,6 +157,7 @@ module psb_c_base_vect_mod procedure, pass(x) :: set_vect => c_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> c_base_get_entry + procedure, pass(x) :: set_entry=> c_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -1275,15 +1276,33 @@ contains ! function c_base_get_entry(x, index) result(res) implicit none - class(psb_c_base_vect_type), intent(in) :: x + class(psb_c_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_spk_) :: res res = 0 - if (allocated(x%v)) res = x%v(index) + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function c_base_get_entry + subroutine c_base_set_entry(x, index, val) + implicit none + class(psb_c_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: val + + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + + end subroutine c_base_set_entry + ! ! Overwrite with absolute value ! diff --git a/base/modules/serial/psb_c_vect_mod.F90 b/base/modules/serial/psb_c_vect_mod.F90 index b418a30e..5e628ff9 100644 --- a/base/modules/serial/psb_c_vect_mod.F90 +++ b/base/modules/serial/psb_c_vect_mod.F90 @@ -108,6 +108,7 @@ module psb_c_vect_mod procedure, pass(x) :: check_addr => c_vect_check_addr procedure, pass(x) :: get_entry => c_vect_get_entry + procedure, pass(x) :: set_entry => c_vect_set_entry procedure, pass(x) :: dot_v => c_vect_dot_v procedure, pass(x) :: dot_a => c_vect_dot_a @@ -855,13 +856,21 @@ contains function c_vect_get_entry(x,index) result(res) implicit none - class(psb_c_vect_type), intent(in) :: x + class(psb_c_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_spk_) :: res - res = 0 + res = czero if (allocated(x%v)) res = x%v%get_entry(index) end function c_vect_get_entry + subroutine c_vect_set_entry(x,index,val) + implicit none + class(psb_c_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_spk_) :: val + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine c_vect_set_entry + function c_vect_dot_v(n,x,y) result(res) implicit none class(psb_c_vect_type), intent(inout) :: x, y diff --git a/base/modules/serial/psb_d_base_vect_mod.F90 b/base/modules/serial/psb_d_base_vect_mod.F90 index fa2c4866..cfdbcee5 100644 --- a/base/modules/serial/psb_d_base_vect_mod.F90 +++ b/base/modules/serial/psb_d_base_vect_mod.F90 @@ -157,6 +157,7 @@ module psb_d_base_vect_mod procedure, pass(x) :: set_vect => d_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> d_base_get_entry + procedure, pass(x) :: set_entry=> d_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -1282,15 +1283,33 @@ contains ! function d_base_get_entry(x, index) result(res) implicit none - class(psb_d_base_vect_type), intent(in) :: x + class(psb_d_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_dpk_) :: res res = 0 - if (allocated(x%v)) res = x%v(index) + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function d_base_get_entry + subroutine d_base_set_entry(x, index, val) + implicit none + class(psb_d_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: val + + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + + end subroutine d_base_set_entry + ! ! Overwrite with absolute value ! @@ -2190,7 +2209,7 @@ contains end do #else ! - ! From M&R: if the array is of size zero, MINVAL + ! From M&R&C: if the array is of size zero, MINVAL ! returns the largest positive value ! res = minval(x%v(1:n)) diff --git a/base/modules/serial/psb_d_vect_mod.F90 b/base/modules/serial/psb_d_vect_mod.F90 index 57d66d5b..cfa3fe6f 100644 --- a/base/modules/serial/psb_d_vect_mod.F90 +++ b/base/modules/serial/psb_d_vect_mod.F90 @@ -108,6 +108,7 @@ module psb_d_vect_mod procedure, pass(x) :: check_addr => d_vect_check_addr procedure, pass(x) :: get_entry => d_vect_get_entry + procedure, pass(x) :: set_entry => d_vect_set_entry procedure, pass(x) :: dot_v => d_vect_dot_v procedure, pass(x) :: dot_a => d_vect_dot_a @@ -862,13 +863,21 @@ contains function d_vect_get_entry(x,index) result(res) implicit none - class(psb_d_vect_type), intent(in) :: x + class(psb_d_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_dpk_) :: res - res = 0 + res = dzero if (allocated(x%v)) res = x%v%get_entry(index) end function d_vect_get_entry + subroutine d_vect_set_entry(x,index,val) + implicit none + class(psb_d_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_dpk_) :: val + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine d_vect_set_entry + function d_vect_dot_v(n,x,y) result(res) implicit none class(psb_d_vect_type), intent(inout) :: x, y @@ -1430,7 +1439,7 @@ contains if (allocated(x%v)) then res = x%v%minreal(n) else - res = dzero + res = HUGE(done) end if end function d_vect_min diff --git a/base/modules/serial/psb_s_base_vect_mod.F90 b/base/modules/serial/psb_s_base_vect_mod.F90 index e6248aae..814b11a5 100644 --- a/base/modules/serial/psb_s_base_vect_mod.F90 +++ b/base/modules/serial/psb_s_base_vect_mod.F90 @@ -157,6 +157,7 @@ module psb_s_base_vect_mod procedure, pass(x) :: set_vect => s_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> s_base_get_entry + procedure, pass(x) :: set_entry=> s_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -1282,15 +1283,33 @@ contains ! function s_base_get_entry(x, index) result(res) implicit none - class(psb_s_base_vect_type), intent(in) :: x + class(psb_s_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_spk_) :: res res = 0 - if (allocated(x%v)) res = x%v(index) + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function s_base_get_entry + subroutine s_base_set_entry(x, index, val) + implicit none + class(psb_s_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: val + + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + + end subroutine s_base_set_entry + ! ! Overwrite with absolute value ! @@ -2190,7 +2209,7 @@ contains end do #else ! - ! From M&R: if the array is of size zero, MINVAL + ! From M&R&C: if the array is of size zero, MINVAL ! returns the largest positive value ! res = minval(x%v(1:n)) diff --git a/base/modules/serial/psb_s_vect_mod.F90 b/base/modules/serial/psb_s_vect_mod.F90 index 8c5841a7..3128866a 100644 --- a/base/modules/serial/psb_s_vect_mod.F90 +++ b/base/modules/serial/psb_s_vect_mod.F90 @@ -108,6 +108,7 @@ module psb_s_vect_mod procedure, pass(x) :: check_addr => s_vect_check_addr procedure, pass(x) :: get_entry => s_vect_get_entry + procedure, pass(x) :: set_entry => s_vect_set_entry procedure, pass(x) :: dot_v => s_vect_dot_v procedure, pass(x) :: dot_a => s_vect_dot_a @@ -862,13 +863,21 @@ contains function s_vect_get_entry(x,index) result(res) implicit none - class(psb_s_vect_type), intent(in) :: x + class(psb_s_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index real(psb_spk_) :: res - res = 0 + res = szero if (allocated(x%v)) res = x%v%get_entry(index) end function s_vect_get_entry + subroutine s_vect_set_entry(x,index,val) + implicit none + class(psb_s_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + real(psb_spk_) :: val + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine s_vect_set_entry + function s_vect_dot_v(n,x,y) result(res) implicit none class(psb_s_vect_type), intent(inout) :: x, y @@ -1430,7 +1439,7 @@ contains if (allocated(x%v)) then res = x%v%minreal(n) else - res = szero + res = HUGE(sone) end if end function s_vect_min diff --git a/base/modules/serial/psb_z_base_vect_mod.F90 b/base/modules/serial/psb_z_base_vect_mod.F90 index 87d911e7..b236beb7 100644 --- a/base/modules/serial/psb_z_base_vect_mod.F90 +++ b/base/modules/serial/psb_z_base_vect_mod.F90 @@ -157,6 +157,7 @@ module psb_z_base_vect_mod procedure, pass(x) :: set_vect => z_base_set_vect generic, public :: set => set_vect, set_scal procedure, pass(x) :: get_entry=> z_base_get_entry + procedure, pass(x) :: set_entry=> z_base_set_entry ! ! Gather/scatter. These are needed for MPI interfacing. ! May have to be reworked. @@ -1275,15 +1276,33 @@ contains ! function z_base_get_entry(x, index) result(res) implicit none - class(psb_z_base_vect_type), intent(in) :: x + class(psb_z_base_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_dpk_) :: res res = 0 - if (allocated(x%v)) res = x%v(index) + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + res = x%v(index) + end if end function z_base_get_entry + subroutine z_base_set_entry(x, index, val) + implicit none + class(psb_z_base_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: val + + + if (allocated(x%v)) then + if (x%is_dev()) call x%sync() + x%v(index) =val + call x%set_host() + end if + + end subroutine z_base_set_entry + ! ! Overwrite with absolute value ! diff --git a/base/modules/serial/psb_z_vect_mod.F90 b/base/modules/serial/psb_z_vect_mod.F90 index 082b62ea..f7cf3584 100644 --- a/base/modules/serial/psb_z_vect_mod.F90 +++ b/base/modules/serial/psb_z_vect_mod.F90 @@ -108,6 +108,7 @@ module psb_z_vect_mod procedure, pass(x) :: check_addr => z_vect_check_addr procedure, pass(x) :: get_entry => z_vect_get_entry + procedure, pass(x) :: set_entry => z_vect_set_entry procedure, pass(x) :: dot_v => z_vect_dot_v procedure, pass(x) :: dot_a => z_vect_dot_a @@ -855,13 +856,21 @@ contains function z_vect_get_entry(x,index) result(res) implicit none - class(psb_z_vect_type), intent(in) :: x + class(psb_z_vect_type), intent(inout) :: x integer(psb_ipk_), intent(in) :: index complex(psb_dpk_) :: res - res = 0 + res = zzero if (allocated(x%v)) res = x%v%get_entry(index) end function z_vect_get_entry + subroutine z_vect_set_entry(x,index,val) + implicit none + class(psb_z_vect_type), intent(inout) :: x + integer(psb_ipk_), intent(in) :: index + complex(psb_dpk_) :: val + if (allocated(x%v)) call x%v%set_entry(index,val) + end subroutine z_vect_set_entry + function z_vect_dot_v(n,x,y) result(res) implicit none class(psb_z_vect_type), intent(inout) :: x, y diff --git a/cbind/base/psb_base_cbind_mod.f90 b/cbind/base/psb_base_cbind_mod.f90 index 036e662a..67d97aad 100644 --- a/cbind/base/psb_base_cbind_mod.f90 +++ b/cbind/base/psb_base_cbind_mod.f90 @@ -1,6 +1,10 @@ module psb_base_cbind_mod use psb_objhandle_mod use psb_cpenv_mod + use psb_s_serial_cbind_mod + use psb_d_serial_cbind_mod + use psb_c_serial_cbind_mod + use psb_z_serial_cbind_mod use psb_base_tools_cbind_mod use psb_s_tools_cbind_mod use psb_d_tools_cbind_mod diff --git a/cbind/base/psb_c_cbase.h b/cbind/base/psb_c_cbase.h index 45b6c825..67651f57 100644 --- a/cbind/base/psb_c_cbase.h +++ b/cbind/base/psb_c_cbase.h @@ -64,8 +64,10 @@ psb_i_t psb_c_cspasb_opt(psb_c_cspmat *mh, psb_c_descriptor *cdh, const char *afmt, psb_i_t upd, psb_i_t dupl); psb_i_t psb_c_csprn(psb_c_cspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_cmat_name_print(psb_c_cspmat *mh, char *name); -psb_i_t psb_c_cvect_set_scal(psb_c_cvector *xh, psb_c_t val); -psb_i_t psb_c_cvect_set_vect(psb_c_cvector *xh, psb_c_t *val, psb_i_t n); +psb_i_t psb_c_cvect_set_scal(psb_c_cvector *xh, psb_c_t val); +psb_i_t psb_c_cvect_set_vect(psb_c_cvector *xh, psb_c_t *val, psb_i_t n); +psb_c_t psb_c_cvect_get_entry(psb_c_cvector *xh, psb_i_t index); +psb_i_t psb_c_cvect_set_entry(psb_c_cvector *xh, psb_i_t index, psb_c_t val); /* psblas computational routines */ psb_c_t psb_c_cgedot(psb_c_cvector *xh, psb_c_cvector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_dbase.h b/cbind/base/psb_c_dbase.h index bf0be8ba..6a6de8be 100644 --- a/cbind/base/psb_c_dbase.h +++ b/cbind/base/psb_c_dbase.h @@ -65,8 +65,10 @@ psb_i_t psb_c_dspasb_opt(psb_c_dspmat *mh, psb_c_descriptor *cdh, const char *afmt, psb_i_t upd, psb_i_t dupl); psb_i_t psb_c_dsprn(psb_c_dspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_dmat_name_print(psb_c_dspmat *mh, char *name); -psb_i_t psb_c_dvect_set_scal(psb_c_dvector *xh, psb_d_t val); -psb_i_t psb_c_dvect_set_vect(psb_c_dvector *xh, psb_d_t *val, psb_i_t n); +psb_i_t psb_c_dvect_set_scal(psb_c_dvector *xh, psb_d_t val); +psb_i_t psb_c_dvect_set_vect(psb_c_dvector *xh, psb_d_t *val, psb_i_t n); +psb_d_t psb_c_dvect_get_entry(psb_c_dvector *xh, psb_i_t index); +psb_i_t psb_c_dvect_set_entry(psb_c_dvector *xh, psb_i_t index, psb_d_t val); /* psblas computational routines */ psb_d_t psb_c_dgedot(psb_c_dvector *xh, psb_c_dvector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_psblas_cbind_mod.f90 b/cbind/base/psb_c_psblas_cbind_mod.f90 index cad71657..ad3aee04 100644 --- a/cbind/base/psb_c_psblas_cbind_mod.f90 +++ b/cbind/base/psb_c_psblas_cbind_mod.f90 @@ -429,14 +429,13 @@ contains function psb_c_cgecmp(xh,ch,zh,cdh) bind(c) result(res) implicit none integer(psb_c_ipk_) :: res - + real(c_float_complex), value :: ch type(psb_c_cvector) :: xh,zh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_c_vect_type), pointer :: xp,zp integer(psb_c_ipk_) :: info - real(c_float_complex), value :: ch res = -1 diff --git a/cbind/base/psb_c_sbase.h b/cbind/base/psb_c_sbase.h index fa501a50..ae1ff71e 100644 --- a/cbind/base/psb_c_sbase.h +++ b/cbind/base/psb_c_sbase.h @@ -65,8 +65,11 @@ psb_i_t psb_c_scopy_mat(psb_c_sspmat *ah,psb_c_sspmat *bh,psb_c_descriptor *cd const char *afmt, psb_i_t upd, psb_i_t dupl); psb_i_t psb_c_ssprn(psb_c_sspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_smat_name_print(psb_c_sspmat *mh, char *name); -psb_i_t psb_c_svect_set_scal(psb_c_svector *xh, psb_s_t val); -psb_i_t psb_c_svect_set_vect(psb_c_svector *xh, psb_s_t *val, psb_i_t n); +psb_i_t psb_c_svect_set_scal(psb_c_svector *xh, psb_s_t val); +psb_i_t psb_c_svect_set_vect(psb_c_svector *xh, psb_s_t *val, psb_i_t n); +psb_s_t psb_c_svect_get_entry(psb_c_svector *xh, psb_i_t index); +psb_i_t psb_c_svect_set_entry(psb_c_svector *xh, psb_i_t index, psb_s_t val); + /* psblas computational routines */ psb_s_t psb_c_sgedot(psb_c_svector *xh, psb_c_svector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_c_serial_cbind_mod.F90 b/cbind/base/psb_c_serial_cbind_mod.F90 index 805f4965..7de87ccc 100644 --- a/cbind/base/psb_c_serial_cbind_mod.F90 +++ b/cbind/base/psb_c_serial_cbind_mod.F90 @@ -200,6 +200,51 @@ contains end function psb_c_cvect_set_vect + function psb_c_cvect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_cvector) :: x + type(psb_c_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + complex(c_float_complex), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_cvect_set_entry + + + function psb_c_cvect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_cvector) :: x + type(psb_c_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + complex(c_float_complex) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_cvect_get_entry function psb_c_cvect_clone(xh,yh) bind(c) result(info) implicit none diff --git a/cbind/base/psb_c_tools_cbind_mod.F90 b/cbind/base/psb_c_tools_cbind_mod.F90 index 76849283..05267b7a 100644 --- a/cbind/base/psb_c_tools_cbind_mod.F90 +++ b/cbind/base/psb_c_tools_cbind_mod.F90 @@ -281,13 +281,19 @@ contains end if ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_geins(nz,irw(1:nz),val(1:nz),& - & xp,descp,info) - else + select case(ixb) + case (0) + !write(0,*) 'C_GEINS: IDX_BASE',ixb,' :',irw(1:nz)+(1-ixb),val(1:nz) call psb_geins(nz,(irw(1:nz)+(1-ixb)),val(1:nz),& & xp,descp,info) - end if + case(1) + !write(0,*) 'C_GEINS: IDX_BASE',ixb,' :',irw(1:nz),val(1:nz) + call psb_geins(nz,irw(1:nz),val(1:nz),& + & xp,descp,info) + case default + write(0,*) 'C_GEINS: Unkonwn inndex base ',ixb + info =-2 + end select res = min(0,info) diff --git a/cbind/base/psb_c_zbase.h b/cbind/base/psb_c_zbase.h index fed51efb..ac7d2b6c 100644 --- a/cbind/base/psb_c_zbase.h +++ b/cbind/base/psb_c_zbase.h @@ -66,8 +66,10 @@ psb_i_t psb_c_zspasb_opt(psb_c_zspmat *mh, psb_c_descriptor *cdh, const char *afmt, psb_i_t upd, psb_i_t dupl); psb_i_t psb_c_zsprn(psb_c_zspmat *mh, psb_c_descriptor *cdh, _Bool clear); psb_i_t psb_c_zmat_name_print(psb_c_zspmat *mh, char *name); -psb_i_t psb_c_zvect_set_scal(psb_c_zvector *xh, psb_z_t val); -psb_i_t psb_c_zvect_set_vect(psb_c_zvector *xh, psb_z_t *val, psb_i_t n); +psb_i_t psb_c_zvect_set_scal(psb_c_zvector *xh, psb_z_t val); +psb_i_t psb_c_zvect_set_vect(psb_c_zvector *xh, psb_z_t *val, psb_i_t n); +psb_z_t psb_c_zvect_get_entry(psb_c_zvector *xh, psb_i_t index); +psb_i_t psb_c_zvect_set_entry(psb_c_zvector *xh, psb_i_t index, psb_z_t val); /* psblas computational routines */ psb_z_t psb_c_zgedot(psb_c_zvector *xh, psb_c_zvector *yh, psb_c_descriptor *cdh); diff --git a/cbind/base/psb_d_psblas_cbind_mod.f90 b/cbind/base/psb_d_psblas_cbind_mod.f90 index 1a8874c5..bb77272e 100644 --- a/cbind/base/psb_d_psblas_cbind_mod.f90 +++ b/cbind/base/psb_d_psblas_cbind_mod.f90 @@ -429,14 +429,13 @@ contains function psb_c_dgecmp(xh,ch,zh,cdh) bind(c) result(res) implicit none integer(psb_c_ipk_) :: res - + real(c_double), value :: ch type(psb_c_dvector) :: xh,zh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_d_vect_type), pointer :: xp,zp integer(psb_c_ipk_) :: info - real(c_double), value :: ch res = -1 diff --git a/cbind/base/psb_d_serial_cbind_mod.F90 b/cbind/base/psb_d_serial_cbind_mod.F90 index 04d840bd..c365eb55 100644 --- a/cbind/base/psb_d_serial_cbind_mod.F90 +++ b/cbind/base/psb_d_serial_cbind_mod.F90 @@ -200,6 +200,51 @@ contains end function psb_c_dvect_set_vect + function psb_c_dvect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_dvector) :: x + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + real(c_double), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_dvect_set_entry + + + function psb_c_dvect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_dvector) :: x + type(psb_d_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + real(c_double) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_dvect_get_entry function psb_c_dvect_clone(xh,yh) bind(c) result(info) implicit none diff --git a/cbind/base/psb_d_tools_cbind_mod.F90 b/cbind/base/psb_d_tools_cbind_mod.F90 index daa28026..11d56d2b 100644 --- a/cbind/base/psb_d_tools_cbind_mod.F90 +++ b/cbind/base/psb_d_tools_cbind_mod.F90 @@ -281,13 +281,19 @@ contains end if ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_geins(nz,irw(1:nz),val(1:nz),& - & xp,descp,info) - else + select case(ixb) + case (0) + !write(0,*) 'C_GEINS: IDX_BASE',ixb,' :',irw(1:nz)+(1-ixb),val(1:nz) call psb_geins(nz,(irw(1:nz)+(1-ixb)),val(1:nz),& & xp,descp,info) - end if + case(1) + !write(0,*) 'C_GEINS: IDX_BASE',ixb,' :',irw(1:nz),val(1:nz) + call psb_geins(nz,irw(1:nz),val(1:nz),& + & xp,descp,info) + case default + write(0,*) 'C_GEINS: Unkonwn inndex base ',ixb + info =-2 + end select res = min(0,info) diff --git a/cbind/base/psb_s_psblas_cbind_mod.f90 b/cbind/base/psb_s_psblas_cbind_mod.f90 index eeabfdbc..382cabd0 100644 --- a/cbind/base/psb_s_psblas_cbind_mod.f90 +++ b/cbind/base/psb_s_psblas_cbind_mod.f90 @@ -429,14 +429,13 @@ contains function psb_c_sgecmp(xh,ch,zh,cdh) bind(c) result(res) implicit none integer(psb_c_ipk_) :: res - + real(c_float), value :: ch type(psb_c_svector) :: xh,zh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_s_vect_type), pointer :: xp,zp integer(psb_c_ipk_) :: info - real(c_float), value :: ch res = -1 diff --git a/cbind/base/psb_s_serial_cbind_mod.F90 b/cbind/base/psb_s_serial_cbind_mod.F90 index e9f65bab..d78cc549 100644 --- a/cbind/base/psb_s_serial_cbind_mod.F90 +++ b/cbind/base/psb_s_serial_cbind_mod.F90 @@ -200,6 +200,51 @@ contains end function psb_c_svect_set_vect + function psb_c_svect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_svector) :: x + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + real(c_float), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_svect_set_entry + + + function psb_c_svect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_svector) :: x + type(psb_s_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + real(c_float) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_svect_get_entry function psb_c_svect_clone(xh,yh) bind(c) result(info) implicit none diff --git a/cbind/base/psb_s_tools_cbind_mod.F90 b/cbind/base/psb_s_tools_cbind_mod.F90 index 2bc6b2d6..fe6b0aae 100644 --- a/cbind/base/psb_s_tools_cbind_mod.F90 +++ b/cbind/base/psb_s_tools_cbind_mod.F90 @@ -281,13 +281,19 @@ contains end if ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_geins(nz,irw(1:nz),val(1:nz),& - & xp,descp,info) - else + select case(ixb) + case (0) + !write(0,*) 'C_GEINS: IDX_BASE',ixb,' :',irw(1:nz)+(1-ixb),val(1:nz) call psb_geins(nz,(irw(1:nz)+(1-ixb)),val(1:nz),& & xp,descp,info) - end if + case(1) + !write(0,*) 'C_GEINS: IDX_BASE',ixb,' :',irw(1:nz),val(1:nz) + call psb_geins(nz,irw(1:nz),val(1:nz),& + & xp,descp,info) + case default + write(0,*) 'C_GEINS: Unkonwn inndex base ',ixb + info =-2 + end select res = min(0,info) diff --git a/cbind/base/psb_z_psblas_cbind_mod.f90 b/cbind/base/psb_z_psblas_cbind_mod.f90 index 511b390f..5255485f 100644 --- a/cbind/base/psb_z_psblas_cbind_mod.f90 +++ b/cbind/base/psb_z_psblas_cbind_mod.f90 @@ -429,14 +429,13 @@ contains function psb_c_zgecmp(xh,ch,zh,cdh) bind(c) result(res) implicit none integer(psb_c_ipk_) :: res - + real(c_double_complex), value :: ch type(psb_c_zvector) :: xh,zh type(psb_c_descriptor) :: cdh type(psb_desc_type), pointer :: descp type(psb_z_vect_type), pointer :: xp,zp integer(psb_c_ipk_) :: info - real(c_double_complex), value :: ch res = -1 diff --git a/cbind/base/psb_z_serial_cbind_mod.F90 b/cbind/base/psb_z_serial_cbind_mod.F90 index fa3d7e12..8c6154af 100644 --- a/cbind/base/psb_z_serial_cbind_mod.F90 +++ b/cbind/base/psb_z_serial_cbind_mod.F90 @@ -200,6 +200,51 @@ contains end function psb_c_zvect_set_vect + function psb_c_zvect_set_entry(x,index,val) bind(c) result(info) + use psb_base_mod + implicit none + + type(psb_c_zvector) :: x + type(psb_z_vect_type), pointer :: xp + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + complex(c_double_complex), value :: val + integer(psb_c_ipk_) :: ixb + + info = -1; + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + call xp%set_entry((index+(1-ixb)),val) + info = 0 + + end function psb_c_zvect_set_entry + + + function psb_c_zvect_get_entry(x,index) bind(c) result(res) + use psb_base_mod + implicit none + + type(psb_c_zvector) :: x + type(psb_z_vect_type), pointer :: xp + integer(psb_c_ipk_), value :: index + complex(c_double_complex) :: res + integer(psb_c_ipk_) :: ixb + + if (c_associated(x%item)) then + call c_f_pointer(x%item,xp) + else + return + end if + + ixb = psb_c_get_index_base() + res = xp%get_entry((index+(1-ixb))) + end function psb_c_zvect_get_entry function psb_c_zvect_clone(xh,yh) bind(c) result(info) implicit none diff --git a/cbind/base/psb_z_tools_cbind_mod.F90 b/cbind/base/psb_z_tools_cbind_mod.F90 index fe6c69b6..2721924c 100644 --- a/cbind/base/psb_z_tools_cbind_mod.F90 +++ b/cbind/base/psb_z_tools_cbind_mod.F90 @@ -281,13 +281,19 @@ contains end if ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_geins(nz,irw(1:nz),val(1:nz),& - & xp,descp,info) - else + select case(ixb) + case (0) + !write(0,*) 'C_GEINS: IDX_BASE',ixb,' :',irw(1:nz)+(1-ixb),val(1:nz) call psb_geins(nz,(irw(1:nz)+(1-ixb)),val(1:nz),& & xp,descp,info) - end if + case(1) + !write(0,*) 'C_GEINS: IDX_BASE',ixb,' :',irw(1:nz),val(1:nz) + call psb_geins(nz,irw(1:nz),val(1:nz),& + & xp,descp,info) + case default + write(0,*) 'C_GEINS: Unkonwn inndex base ',ixb + info =-2 + end select res = min(0,info) diff --git a/test/pdegen/psb_d_pde2d.F90 b/test/pdegen/psb_d_pde2d.F90 index 7da7439b..07532098 100644 --- a/test/pdegen/psb_d_pde2d.F90 +++ b/test/pdegen/psb_d_pde2d.F90 @@ -230,7 +230,7 @@ contains f_ => d_null_func_2d end if - deltah = done/(idim+1) + deltah = done/(idim+2) sqdeltah = deltah*deltah deltah2 = (2*done)* deltah @@ -467,8 +467,8 @@ contains ! compute gridpoint coordinates call idx2ijk(ix,iy,glob_row,idim,idim) ! x, y coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah + x = (ix)*deltah + y = (iy)*deltah zt(k) = f_(x,y) ! internal point: build discretization diff --git a/test/pdegen/psb_d_pde3d.F90 b/test/pdegen/psb_d_pde3d.F90 index 982e582c..57c5905d 100644 --- a/test/pdegen/psb_d_pde3d.F90 +++ b/test/pdegen/psb_d_pde3d.F90 @@ -246,7 +246,7 @@ contains f_ => d_null_func_3d end if - deltah = done/(idim+1) + deltah = done/(idim+2) sqdeltah = deltah*deltah deltah2 = (2*done)* deltah @@ -496,9 +496,9 @@ contains ! compute gridpoint coordinates call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) ! x, y, z coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah - z = (iz-1)*deltah + x = (ix)*deltah + y = (iy)*deltah + z = (iz)*deltah zt(k) = f_(x,y,z) ! internal point: build discretization ! diff --git a/test/pdegen/psb_s_pde2d.F90 b/test/pdegen/psb_s_pde2d.F90 index 1df7b138..43ad13a5 100644 --- a/test/pdegen/psb_s_pde2d.F90 +++ b/test/pdegen/psb_s_pde2d.F90 @@ -230,7 +230,7 @@ contains f_ => s_null_func_2d end if - deltah = sone/(idim+1) + deltah = sone/(idim+2) sqdeltah = deltah*deltah deltah2 = (2*sone)* deltah @@ -467,8 +467,8 @@ contains ! compute gridpoint coordinates call idx2ijk(ix,iy,glob_row,idim,idim) ! x, y coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah + x = (ix)*deltah + y = (iy)*deltah zt(k) = f_(x,y) ! internal point: build discretization diff --git a/test/pdegen/psb_s_pde3d.F90 b/test/pdegen/psb_s_pde3d.F90 index ac4dfbdf..86683196 100644 --- a/test/pdegen/psb_s_pde3d.F90 +++ b/test/pdegen/psb_s_pde3d.F90 @@ -246,7 +246,7 @@ contains f_ => s_null_func_3d end if - deltah = sone/(idim+1) + deltah = sone/(idim+2) sqdeltah = deltah*deltah deltah2 = (2*sone)* deltah @@ -496,9 +496,9 @@ contains ! compute gridpoint coordinates call idx2ijk(ix,iy,iz,glob_row,idim,idim,idim) ! x, y, z coordinates - x = (ix-1)*deltah - y = (iy-1)*deltah - z = (iz-1)*deltah + x = (ix)*deltah + y = (iy)*deltah + z = (iz)*deltah zt(k) = f_(x,y,z) ! internal point: build discretization !