diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 73344958..273c8c33 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -287,6 +287,12 @@ set(PSB_base_source_files serial/impl/psb_z_base_vect_impl.F90 serial/impl/psb_s_base_vect_impl.F90 serial/impl/psb_d_base_vect_impl.F90 + serial/impl/psb_i_vect_impl.F90 + serial/impl/psb_l_vect_impl.F90 + serial/impl/psb_c_vect_impl.F90 + serial/impl/psb_z_vect_impl.F90 + serial/impl/psb_s_vect_impl.F90 + serial/impl/psb_d_vect_impl.F90 serial/impl/psb_c_coo_impl.F90 serial/impl/psb_d_coo_impl.F90 serial/impl/psb_d_csc_impl.F90 diff --git a/cbind/CMakeLists.txt b/cbind/CMakeLists.txt index c700b5a8..e5fdfe2b 100644 --- a/cbind/CMakeLists.txt +++ b/cbind/CMakeLists.txt @@ -20,6 +20,22 @@ set(PSB_cbind_source_files base/psb_d_comm_cbind_mod.f90 base/psb_z_tools_cbind_mod.F90 base/psb_cpenv_mod.F90 + base/psb_c_comm_cbind_impl.f90 + base/psb_c_psblas_cbind_impl.f90 + base/psb_c_serial_cbind_impl.F90 + base/psb_c_tools_cbind_impl.F90 + base/psb_d_comm_cbind_impl.f90 + base/psb_d_psblas_cbind_impl.f90 + base/psb_d_serial_cbind_impl.F90 + base/psb_d_tools_cbind_impl.F90 + base/psb_s_comm_cbind_impl.f90 + base/psb_s_psblas_cbind_impl.f90 + base/psb_s_serial_cbind_impl.F90 + base/psb_s_tools_cbind_impl.F90 + base/psb_z_comm_cbind_impl.f90 + base/psb_z_psblas_cbind_impl.f90 + base/psb_z_serial_cbind_impl.F90 + base/psb_z_tools_cbind_impl.F90 util/psb_c_util_cbind_mod.f90 util/psb_s_util_cbind_mod.f90 util/psb_util_cbind_mod.f90 diff --git a/cbind/base/Makefile b/cbind/base/Makefile index 9d4d734c..893d0f0c 100644 --- a/cbind/base/Makefile +++ b/cbind/base/Makefile @@ -8,7 +8,7 @@ HERE=.. FINCLUDES=$(FMFLAG). $(FMFLAG)$(HERE) $(FMFLAG)$(MODDIR) CINCLUDES=-I. -I$(HERE) -I$(INCLUDEDIR) -FOBJS= psb_objhandle_mod.o psb_base_cbind_mod.o psb_cpenv_mod.o \ +FMODS= psb_objhandle_mod.o psb_base_cbind_mod.o psb_cpenv_mod.o \ psb_base_tools_cbind_mod.o psb_base_psblas_cbind_mod.o \ psb_s_tools_cbind_mod.o psb_s_serial_cbind_mod.o psb_s_psblas_cbind_mod.o \ psb_d_tools_cbind_mod.o psb_d_serial_cbind_mod.o psb_d_psblas_cbind_mod.o \ @@ -16,14 +16,32 @@ FOBJS= psb_objhandle_mod.o psb_base_cbind_mod.o psb_cpenv_mod.o \ psb_z_tools_cbind_mod.o psb_z_serial_cbind_mod.o psb_z_psblas_cbind_mod.o \ psb_s_comm_cbind_mod.o psb_d_comm_cbind_mod.o \ psb_c_comm_cbind_mod.o psb_z_comm_cbind_mod.o +FOBJS=psb_s_serial_cbind_impl.o \ + psb_d_serial_cbind_impl.o \ + psb_c_serial_cbind_impl.o \ + psb_z_serial_cbind_impl.o \ + psb_s_comm_cbind_impl.o \ + psb_d_comm_cbind_impl.o \ + psb_c_comm_cbind_impl.o \ + psb_z_comm_cbind_impl.o \ + psb_s_psblas_cbind_impl.o \ + psb_d_psblas_cbind_impl.o \ + psb_c_psblas_cbind_impl.o \ + psb_z_psblas_cbind_impl.o \ + psb_s_tools_cbind_impl.o \ + psb_d_tools_cbind_impl.o \ + psb_c_tools_cbind_impl.o \ + psb_z_tools_cbind_impl.o COBJS= psb_c_base.o psb_c_sbase.o psb_c_dbase.o psb_c_cbase.o psb_c_zbase.o \ psb_c_scomm.o psb_c_dcomm.o psb_c_ccomm.o psb_c_zcomm.o -CMOD=psb_base_cbind.h psb_c_base.h psb_c_sbase.h psb_c_dbase.h psb_c_cbase.h psb_c_zbase.h \ - psb_c_scomm.h psb_c_dcomm.h psb_c_ccomm.h psb_c_zcomm.h -OBJS=$(FOBJS) $(COBJS) +CMOD=psb_base_cbind.h psb_c_base.h \ + psb_c_sbase.h psb_c_dbase.h psb_c_cbase.h psb_c_zbase.h \ + psb_c_scomm.h psb_c_dcomm.h psb_c_ccomm.h psb_c_zcomm.h +OBJS=$(FMODS) $(FOBJS) $(COBJS) LIBNAME=$(CBINDLIBNAME) +$(FOBJS): $(FMODS) # Ensure C-interoperable modules are built with CUDA definitions where available. .F90.o: @@ -67,6 +85,6 @@ veryclean: clean /bin/rm -f $(HERE)/$(LIBNAME) clean: - /bin/rm -f $(OBJS) *$(.mod) + /bin/rm -f $(OBJS) *$(.mod) *.smod veryclean: clean diff --git a/cbind/base/psb_c_comm_cbind_mod.f90 b/cbind/base/psb_c_comm_cbind_mod.f90 index 9d5b9ef4..f306c2cc 100644 --- a/cbind/base/psb_c_comm_cbind_mod.f90 +++ b/cbind/base/psb_c_comm_cbind_mod.f90 @@ -3,236 +3,67 @@ module psb_c_comm_cbind_mod use psb_base_mod use psb_objhandle_mod -contains - - function psb_c_covrl(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_ovrl(xp,descp,info) - - res = info - - end function psb_c_covrl - - function psb_c_covrl_opt(xh,cdh,update,mode) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: update, mode - - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_ovrl(xp,descp,info,update=update,mode=mode) - - res = info - - end function psb_c_covrl_opt - - - function psb_c_chalo(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_halo(xp,descp,info) - - res = info - - end function psb_c_chalo - - function psb_c_chalo_opt(xh,cdh,tran,data,mode) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: data, mode - character(c_char) :: tran - - - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - character :: ftran - integer(psb_c_ipk_) :: info - - - 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 - - ftran = tran - call psb_halo(xp,descp,info,data=data,mode=mode,tran=ftran) - - res = info - - end function psb_c_chalo_opt - - - function psb_c_cvscatter(ng,gx,xh,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - integer(psb_c_lpk_), value :: ng - complex(c_float_complex), target :: gx(*) - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: vp - complex(psb_spk_), pointer :: pgx(:) - integer(psb_c_ipk_) :: info, sz - - 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,vp) - else - return - end if - - pgx => gx(1:ng) - - call psb_scatter(pgx,vp,descp,info) - res = info - - end function psb_c_cvscatter - - function psb_c_cvgather_f(v,xh,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - complex(c_float_complex), target :: v(*) - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: vp - complex(psb_spk_), allocatable :: fv(:) - integer(psb_c_ipk_) :: info, sz - - 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,vp) - else - return - end if - - call psb_gather(fv,vp,descp,info) - res = info - if (res /=0) return - sz = size(fv) - v(1:sz) = fv(1:sz) - end function psb_c_cvgather_f - - function psb_c_cspgather_f(gah,ah,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_cspmat) :: ah, gah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap, gap - integer(psb_c_ipk_) :: info, sz - - 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 - if (c_associated(gah%item)) then - call c_f_pointer(gah%item,gap) - else - return - end if - call psb_gather(gap,ap,descp,info) - res = info - end function psb_c_cspgather_f - + interface + module function psb_c_covrl(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_covrl + end interface + + interface + module function psb_c_covrl_opt(xh,cdh,update,mode) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: update, mode + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_covrl_opt + end interface + + + interface + module function psb_c_chalo(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_chalo + end interface + + interface + module function psb_c_chalo_opt(xh,cdh,tran,data,mode) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: data, mode + character(c_char) :: tran + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_chalo_opt + end interface + + interface + module function psb_c_cvscatter(ng,gx,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_lpk_), value :: ng + complex(c_float_complex), target :: gx(*) + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_cvscatter + end interface + + interface + module function psb_c_cvgather_f(v,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + complex(c_float_complex), target :: v(*) + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_cvgather_f + end interface + + interface + module function psb_c_cspgather_f(gah,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: ah, gah + type(psb_c_descriptor) :: cdh + end function psb_c_cspgather_f + end interface + end module psb_c_comm_cbind_mod diff --git a/cbind/base/psb_c_psblas_cbind_mod.f90 b/cbind/base/psb_c_psblas_cbind_mod.f90 index cad71657..da7f3dad 100644 --- a/cbind/base/psb_c_psblas_cbind_mod.f90 +++ b/cbind/base/psb_c_psblas_cbind_mod.f90 @@ -3,1265 +3,329 @@ module psb_c_psblas_cbind_mod use psb_base_mod use psb_objhandle_mod -contains - function psb_c_cgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - complex(c_float_complex), value :: alpha,beta - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geaxpby(alpha,xp,beta,yp,descp,info) - - res = info - - end function psb_c_cgeaxpby - - function psb_c_cgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - complex(c_float_complex), value :: alpha,beta - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_geaxpby(alpha,xp,beta,yp,zp,descp,info) - - res = info - - end function psb_c_cgeaxpbyz - - function psb_c_cgemlt(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_gemlt(xp,yp,descp,info) - - res = info - - end function psb_c_cgemlt - - function psb_c_cgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh, zh - type(psb_c_descriptor) :: cdh - - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - complex(psb_spk_), intent(in), value :: alpha,beta - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) - - res = info - - end function psb_c_cgemlt2 - - function psb_c_cgediv(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_gediv(xp,yp,descp,info) - - res = info - - end function psb_c_cgediv - - function psb_c_cgediv2(xh,yh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gediv(xp,yp,zp,descp,info) - - res = info - - end function psb_c_cgediv2 - - function psb_c_cgediv_check(xh,yh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - fflag = flag - call psb_gediv(xp,yp,descp,info,fflag) - - res = info - - end function psb_c_cgediv_check - - function psb_c_cgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - fflag = flag - call psb_gediv(xp,yp,zp,descp,info,fflag) - - res = info - - end function psb_c_cgediv2_check - - function psb_c_cgeinv(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geinv(xp,yp,descp,info) - - res = info - - end function psb_c_cgeinv - - function psb_c_cgeinv_check(xh,yh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - fflag = flag - call psb_geinv(xp,yp,descp,info,fflag) - - res = info - - end function psb_c_cgeinv_check - - function psb_c_cgeabs(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geabs(xp,yp,descp,info) - - res = info - - end function psb_c_cgeabs - - function psb_c_cgecmp(xh,ch,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - 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 - - 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 - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gecmp(xp,ch,zp,descp,info) - - res = info - - end function psb_c_cgecmp - - function psb_c_cgecmpmat(ah,bh,tol,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_cspmat) :: ah,bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - real(c_float_complex), value :: tol - logical :: isequal - - res = .false. - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call psb_gecmp(ap,bp,tol,descp,isequal,info) - - res = isequal - - end function psb_c_cgecmpmat - - function psb_c_cgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - complex(c_float_complex), value :: val - real(c_float_complex), value :: tol - logical :: isequal - - res = .false. - - 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 - - call psb_gecmp(ap,val,tol,descp,isequal,info) - - res = isequal - - end function psb_c_cgecmpmat_val - - function psb_c_cgeaddconst(xh,bh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - 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 :: bh - - 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 - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_geaddconst(xp,bh,zp,descp,info) - - res = info - - end function psb_c_cgeaddconst - - - function psb_c_cgenrm2(xh,cdh) bind(c) result(res) - implicit none - real(c_float_complex) :: res - - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - res = psb_genrm2(xp,descp,info) - - end function psb_c_cgenrm2 - - function psb_c_cgenrmi(xh,cdh) bind(c) result(res) - implicit none - real(c_float_complex) :: res - - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - type(psb_c_vect_type) :: yp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - call psb_geall(yp,descp,info) - call psb_geabs(xp,yp,descp,info) - res = psb_geasum(yp,descp,info) - call psb_gefree(yp,descp,info) - - end function psb_c_cgenrmi - - function psb_c_cgenrm2_weight(xh,wh,cdh) bind(c) result(res) - implicit none - real(c_float_complex) :: res - - type(psb_c_cvector) :: xh, wh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp, wp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - if (c_associated(wh%item)) then - call c_f_pointer(wh%item,wp) - else - return - end if - - res = psb_genrm2(xp,wp,descp,info) - - end function psb_c_cgenrm2_weight - - function psb_c_cgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) - implicit none - real(c_float_complex) :: res - - type(psb_c_cvector) :: xh, wh, idvh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp, wp, idvp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - if (c_associated(wh%item)) then - call c_f_pointer(wh%item,wp) - else - return - end if - if (c_associated(idvh%item)) then - call c_f_pointer(idvh%item,idvp) - else - return - end if - - res = psb_genrm2(xp,wp,idvp,descp,info) - - end function psb_c_cgenrm2_weightmask - - function psb_c_cgeamax(xh,cdh) bind(c) result(res) - implicit none - real(c_float_complex) :: res - - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - - res = psb_geamax(xp,descp,info) - - end function psb_c_cgeamax - - - function psb_c_cgeasum(xh,cdh) bind(c) result(res) - implicit none - real(c_float_complex) :: res - - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - res = psb_geasum(xp,descp,info) - - end function psb_c_cgeasum - - - function psb_c_cspnrmi(ah,cdh) bind(c) result(res) - implicit none - real(c_float_complex) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - - res = psb_spnrmi(ap,descp,info) - - end function psb_c_cspnrmi - - function psb_c_cgedot(xh,yh,cdh) bind(c) result(res) - implicit none - complex(c_float_complex) :: res - - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - res = psb_gedot(xp,yp,descp,info) - - end function psb_c_cgedot - - - function psb_c_cspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - complex(c_float_complex), value :: alpha, beta - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - call psb_spmm(alpha,ap,xp,beta,yp,descp,info) - - res = info - - end function psb_c_cspmm - - - function psb_c_cspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - complex(c_float_complex), value :: alpha, beta - character(c_char) :: trans - logical(c_bool), value :: doswap - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - type(psb_cspmat_type), pointer :: ap - character :: ftrans - logical :: fdoswap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - fdoswap = doswap - ftrans = trans - call psb_spmm(alpha,ap,xp,beta,yp,descp,info,trans=ftrans,doswap=fdoswap) - - res = info - - end function psb_c_cspmm_opt - - - function psb_c_cspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_cvector) :: xh,yh - type(psb_c_descriptor) :: cdh - complex(c_float_complex), value :: alpha, beta - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp,yp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - call psb_spsm(alpha,ap,xp,beta,yp,descp,info) - - res = info - - end function psb_c_cspsm - - function psb_c_cnnz(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - - 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 - - res = psb_nnz(ap,descp,info) - - end function psb_c_cnnz - - function psb_c_cis_matupd(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_upd() - end function - - function psb_c_cis_matasb(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_asb() - end function - - function psb_c_cis_matbld(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_bld() - end function - - function psb_c_cset_matupd(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - - 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 - - call ap%set_upd() - - res = psb_success_ - end function - - function psb_c_cset_matasb(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - - 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 - - call ap%set_asb() - - res = psb_success_ - - end function - - function psb_c_cset_matbld(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - - 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 - - call ap%set_bld() - - res = psb_success_ - end function - - function psb_c_ccopy_mat(ah,bh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cspmat) :: ah,bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call ap%clone(bp,info) - - res = info - end function - - function psb_c_cspscal(alpha,ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - complex(c_float_complex), value :: alpha - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - - call ap%scal(alpha,info) - - res = info - - end function psb_c_cspscal - - function psb_c_cspscalpid(alpha,ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - complex(c_float_complex), value :: alpha - type(psb_c_cspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - - call ap%scalpid(alpha,info) - - res = info - - end function psb_c_cspscalpid - - function psb_c_cspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - complex(c_float_complex), value :: alpha - type(psb_c_cspmat) :: ah - complex(c_float_complex), value :: beta - type(psb_c_cspmat) :: bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call ap%spaxpby(alpha,beta,bp,info) - - res = info - end function psb_c_cspaxpby + interface + module function psb_c_cgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + complex(c_float_complex), value :: alpha,beta + end function psb_c_cgeaxpby + end interface + + interface + module function psb_c_cgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + complex(c_float_complex), value :: alpha,beta + end function psb_c_cgeaxpbyz + end interface + + interface + module function psb_c_cgemlt(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_cgemlt + end interface + + interface + module function psb_c_cgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + complex(psb_spk_), intent(in), value :: alpha,beta + end function psb_c_cgemlt2 + end interface + + interface + module function psb_c_cgediv(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_cgediv + end interface + + interface + module function psb_c_cgediv2(xh,yh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + end function psb_c_cgediv2 + end interface + + interface + module function psb_c_cgediv_check(xh,yh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_cgediv_check + end interface + + interface + module function psb_c_cgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_cgediv2_check + end interface + + interface + module function psb_c_cgeinv(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_cgeinv + end interface + + interface + module function psb_c_cgeinv_check(xh,yh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_cgeinv_check + end interface + + interface + module function psb_c_cgeabs(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_cgeabs + end interface + + interface + module function psb_c_cgecmp(xh,ch,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,zh + type(psb_c_descriptor) :: cdh + real(c_float_complex), value :: ch + end function psb_c_cgecmp + end interface + + interface + module function psb_c_cgecmpmat(ah,bh,tol,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_cspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + real(c_float_complex), value :: tol + end function psb_c_cgecmpmat + end interface + + interface + module function psb_c_cgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + complex(c_float_complex), value :: val + real(c_float_complex), value :: tol + end function psb_c_cgecmpmat_val + end interface + + interface + module function psb_c_cgeaddconst(xh,bh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh,zh + type(psb_c_descriptor) :: cdh + real(c_float_complex), value :: bh + end function psb_c_cgeaddconst + end interface + + + interface + module function psb_c_cgenrm2(xh,cdh) bind(c) result(res) + real(c_float_complex) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_cgenrm2 + end interface + + interface + module function psb_c_cgenrmi(xh,cdh) bind(c) result(res) + real(c_float_complex) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_cgenrmi + end interface + + interface + module function psb_c_cgenrm2_weight(xh,wh,cdh) bind(c) result(res) + real(c_float_complex) :: res + type(psb_c_cvector) :: xh, wh + type(psb_c_descriptor) :: cdh + end function psb_c_cgenrm2_weight + end interface + + interface + module function psb_c_cgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) + real(c_float_complex) :: res + type(psb_c_cvector) :: xh, wh, idvh + type(psb_c_descriptor) :: cdh + end function psb_c_cgenrm2_weightmask + end interface + + interface + module function psb_c_cgeamax(xh,cdh) bind(c) result(res) + real(c_float_complex) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_cgeamax + end interface + + + interface + module function psb_c_cgeasum(xh,cdh) bind(c) result(res) + real(c_float_complex) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_cgeasum + end interface + + interface + module function psb_c_cspnrmi(ah,cdh) bind(c) result(res) + real(c_float_complex) :: res + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_cspnrmi + end interface + + interface + module function psb_c_cgedot(xh,yh,cdh) bind(c) result(res) + complex(c_float_complex) :: res + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_cgedot + end interface + + interface + module function psb_c_cspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: ah + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + complex(c_float_complex), value :: alpha, beta + end function psb_c_cspmm + end interface + + interface + module function psb_c_cspmm_opt(alpha,ah,xh,beta,yh,& + & cdh,trans,doswap) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: ah + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + complex(c_float_complex), value :: alpha, beta + character(c_char) :: trans + logical(c_bool), value :: doswap + end function psb_c_cspmm_opt + end interface + + interface + module function psb_c_cspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: ah + type(psb_c_cvector) :: xh,yh + type(psb_c_descriptor) :: cdh + complex(c_float_complex), value :: alpha, beta + type(psb_desc_type), pointer :: descp + end function psb_c_cspsm + end interface + + interface + module function psb_c_cnnz(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_cnnz + end interface + + interface + module function psb_c_cis_matupd(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_cis_matasb(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_cis_matbld(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_cset_matupd(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_cset_matasb(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_cset_matbld(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_ccopy_mat(ah,bh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_cspscal(alpha,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + complex(c_float_complex), value :: alpha + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_cspscal + end interface + + interface + module function psb_c_cspscalpid(alpha,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + complex(c_float_complex), value :: alpha + type(psb_c_cspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_cspscalpid + end interface + + interface + module function psb_c_cspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + complex(c_float_complex), value :: alpha + type(psb_c_cspmat) :: ah + complex(c_float_complex), value :: beta + type(psb_c_cspmat) :: bh + type(psb_c_descriptor) :: cdh + end function psb_c_cspaxpby + end interface end module psb_c_psblas_cbind_mod diff --git a/cbind/base/psb_c_serial_cbind_mod.F90 b/cbind/base/psb_c_serial_cbind_mod.F90 index 1ea736eb..63f48733 100644 --- a/cbind/base/psb_c_serial_cbind_mod.F90 +++ b/cbind/base/psb_c_serial_cbind_mod.F90 @@ -4,293 +4,110 @@ module psb_c_serial_cbind_mod use psb_objhandle_mod use psb_base_tools_cbind_mod -contains - - function psb_c_cvect_get_nrows(xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_cvector) :: xh - - type(psb_c_vect_type), pointer :: vp - integer(psb_c_ipk_) :: info - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - res = vp%get_nrows() - end if - - end function psb_c_cvect_get_nrows - - function psb_c_cvect_f_get_cpy(v,xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - complex(c_float_complex) :: v(*) - type(psb_c_cvector) :: xh - - type(psb_c_vect_type), pointer :: vp - complex(psb_spk_), allocatable :: fv(:) - integer(psb_c_ipk_) :: info, sz - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - fv = vp%get_vect() - sz = size(fv) - v(1:sz) = fv(1:sz) - end if - - end function psb_c_cvect_f_get_cpy - - - function psb_c_cvect_zero(xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_cvector) :: xh - - type(psb_c_vect_type), pointer :: vp - integer(psb_c_ipk_) :: info - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - call vp%zero() - end if - - end function psb_c_cvect_zero - - function psb_c_cvect_f_get_pnt(xh) bind(c) result(res) - implicit none - - type(c_ptr) :: res - type(psb_c_cvector) :: xh - - type(psb_c_vect_type), pointer :: vp - - res = c_null_ptr - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - if(vp%is_dev()) call vp%sync() - res = c_loc(vp%v%v) - end if - - end function psb_c_cvect_f_get_pnt - - - function psb_c_cmat_get_nrows(mh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cspmat) :: mh - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - res = ap%get_nrows() - - end function psb_c_cmat_get_nrows - - - function psb_c_cmat_get_ncols(mh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_cspmat) :: mh - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - res = ap%get_ncols() - - end function psb_c_cmat_get_ncols - - - function psb_c_cmat_name_print(mh,name) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - character(c_char) :: name(*) - type(psb_c_cspmat) :: mh - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - character(1024) :: fname - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - call psb_stringc2f(name,fname) - - call ap%print(fname,head='PSBLAS Cbinding Interface') - - end function psb_c_cmat_name_print - - function psb_c_cvect_set_scal(x,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 - complex(c_float_complex), value :: val - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val) - - info = 0 - - end function psb_c_cvect_set_scal - - function psb_c_cvect_set_scal_bound(x,val,ifirst,ilast) 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 :: ifirst, ilast - complex(c_float_complex) :: val - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val,first=ifirst,last=ilast) - - info = 0 - - end function psb_c_cvect_set_scal_bound - - function psb_c_cvect_set_vect(x,val,n) 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 :: n - complex(c_float_complex) :: val(*) - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val(1:n)) - - info = 0 - - 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 + interface + module function psb_c_cvect_get_nrows(xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + + type(psb_c_vect_type), pointer :: vp + integer(psb_c_ipk_) :: info + end function psb_c_cvect_get_nrows + end interface + + interface + module function psb_c_cvect_f_get_cpy(v,xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + complex(c_float_complex) :: v(*) + type(psb_c_cvector) :: xh + end function psb_c_cvect_f_get_cpy + end interface + + + interface + module function psb_c_cvect_zero(xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + end function psb_c_cvect_zero + end interface + + interface + module function psb_c_cvect_f_get_pnt(xh) bind(c) result(res) + type(c_ptr) :: res + type(psb_c_cvector) :: xh + end function psb_c_cvect_f_get_pnt + end interface + + interface + module function psb_c_cmat_get_nrows(mh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: mh + end function psb_c_cmat_get_nrows + end interface + + interface + module function psb_c_cmat_get_ncols(mh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: mh + end function psb_c_cmat_get_ncols + end interface + + interface + module function psb_c_cmat_name_print(mh,name) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: mh + character(c_char) :: name(*) + end function psb_c_cmat_name_print + end interface + + interface + module function psb_c_cvect_set_scal(x,val) bind(c) result(info) + type(psb_c_cvector) :: x + integer(psb_c_ipk_) :: info + complex(c_float_complex), value :: val + end function psb_c_cvect_set_scal + end interface + + interface + module function psb_c_cvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + type(psb_c_cvector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + complex(c_float_complex) :: val + end function psb_c_cvect_set_scal_bound + end interface + + interface + module function psb_c_cvect_set_vect(x,val,n) bind(c) result(info) + type(psb_c_cvector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: n + complex(c_float_complex) :: val(*) + end function psb_c_cvect_set_vect + end interface + + interface + module function psb_c_cvect_set_entry(x,index,val) bind(c) result(info) + type(psb_c_cvector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + complex(c_float_complex), value :: val + end function psb_c_cvect_set_entry + end interface - 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 - - integer(psb_c_ipk_) :: info - type(psb_c_cvector) :: xh,yh - - type(psb_c_vect_type), pointer :: xp,yp - - info = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - call xp%clone(yp,info) - - end function psb_c_cvect_clone + interface + module function psb_c_cvect_get_entry(x,index) bind(c) result(res) + type(psb_c_cvector) :: x + integer(psb_c_ipk_), value :: index + complex(c_float_complex) :: res + end function psb_c_cvect_get_entry + end interface + + interface + module function psb_c_cvect_clone(xh,yh) bind(c) result(info) + integer(psb_c_ipk_) :: info + type(psb_c_cvector) :: xh,yh + end function psb_c_cvect_clone + end interface end module psb_c_serial_cbind_mod diff --git a/cbind/base/psb_c_tools_cbind_mod.F90 b/cbind/base/psb_c_tools_cbind_mod.F90 index 23c593c4..5f81f0ee 100644 --- a/cbind/base/psb_c_tools_cbind_mod.F90 +++ b/cbind/base/psb_c_tools_cbind_mod.F90 @@ -8,604 +8,145 @@ module psb_c_tools_cbind_mod use psb_cuda_mod #endif -contains - ! Should define geall_opt with DUPL argument - function psb_c_cgeall(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_cgeall - - function psb_c_cgeall_remote(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info,bldmode=psb_matbld_remote_,dupl=psb_dupl_add_) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_cgeall_remote - - function psb_c_cgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: dupl - integer(psb_c_ipk_), value :: bldmode - - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info,bldmode=bldmode,dupl=dupl) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_cgeall_remote_options - - function psb_c_cgeasb(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_geasb(xp,descp,info) - res = min(0,info) - - return - end function psb_c_cgeasb - - function psb_c_cgeasb_options(xh,cdh,dupl) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: dupl - - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_geasb(xp,descp,info,dupl=dupl) - res = min(0,info) - - return - end function psb_c_cgeasb_options - - function psb_c_cgeasb_options_format(xh,cdh,dupl,format) bind(c) result(res) - ! Takes into account format argument as a c string, and uses it to call the appropriate psb_geasb - ! with mold argument - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - character(kind=c_char), dimension(*) :: format - integer(psb_c_ipk_), value :: dupl - - ! Local variables - character(len=6) :: fformat - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - ! mold variables -#ifdef PSB_HAVE_CUDA - type(psb_c_vect_cuda), target :: vgpu -#endif - type(psb_c_base_vect_type), target :: vect - class(psb_c_base_vect_type), pointer :: vmold - - ! Select mold based on format - call psb_stringc2f(format,fformat) - - select case (psb_toupper(fformat)) -#ifdef PSB_HAVE_CUDA - case('GPU','DEVICE') - vmold => vgpu -#endif - case('CPU','HOST') - vmold => vect - case default - write(psb_out_unit,*) 'psb_c_cgeasb_options_format: Unknown format ',fformat - vmold => vect - end select - 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 - - call psb_geasb(xp,descp,info,dupl=dupl,mold=vmold) - res = min(0,info) - - return - end function psb_c_cgeasb_options_format - - - function psb_c_cgefree(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_gefree(xp,descp,info) - res = min(0,info) - deallocate(xp,stat=info) - res = min(0,info) - xh%item = c_null_ptr - - return - end function psb_c_cgefree - - - function psb_c_cgeins(nz,irw,val,xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*) - complex(c_float_complex) :: val(*) - type(psb_c_cvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_c_vect_type), pointer :: xp - integer(psb_c_ipk_) :: ixb, info - - res = -1 - info = 0 - 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 - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_geins(nz,irw(1:nz),val(1:nz),& - & xp,descp,info) - else - call psb_geins(nz,(irw(1:nz)+(1-ixb)),val(1:nz),& - & xp,descp,info) - end if - - res = min(0,info) - - return - end function psb_c_cgeins - - function psb_c_cspall(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - return - end if - allocate(ap) - call psb_spall(ap,descp,info) - mh%item = c_loc(ap) - res = min(0,info) - - return - end function psb_c_cspall - - - function psb_c_cspall_remote(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - return - end if - allocate(ap) - call psb_spall(ap,descp,info,bldmode=psb_matbld_remote_,dupl=psb_dupl_add_) - mh%item = c_loc(ap) - res = min(0,info) - - return - end function psb_c_cspall_remote - - function psb_c_cspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - call psb_spasb(ap,descp,info) - res = min(0,info) - return - end function psb_c_cspasb - - function psb_c_cspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - call psb_spfree(ap,descp,info) - res = min(0,info) - deallocate(ap,stat=info) - mh%item=c_null_ptr - return - end function psb_c_cspfree - - - - - function psb_c_cspasb_opt(mh,cdh,afmt,upd,dupl) bind(c) result(res) - -#if 0 -#ifdef PSB_HAVE_LIBRSB - use psb_c_rsb_mat_mod -#endif -#endif -#if defined(PSB_HAVE_CUDA) - use psb_cuda_mod -#endif - use psb_ext_mod - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_cspmat) :: mh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: upd,dupl - character(c_char) :: afmt(*) - integer(psb_c_ipk_) :: info,n - character(len=5) :: fafmt - integer(psb_ipk_), parameter :: hksz = 32 - ! mold variables -#if 0 -#ifdef PSB_HAVE_LIBRSB - type(psb_c_rsb_sparse_mat) :: arsb -#endif -#endif - type(psb_c_ell_sparse_mat), target :: aell - type(psb_c_csr_sparse_mat), target :: acsr - type(psb_c_csc_sparse_mat), target :: acsc - type(psb_c_coo_sparse_mat), target :: acoo - type(psb_c_hll_sparse_mat), target :: ahll - type(psb_c_hdia_sparse_mat), target :: ahdia - type(psb_c_dns_sparse_mat), target :: adns -#if defined(PSB_HAVE_CUDA) - type(psb_c_cuda_hlg_sparse_mat), target :: ahlg - type(psb_c_cuda_csrg_sparse_mat), target :: acsrg - type(psb_c_cuda_elg_sparse_mat), target :: aelg -#endif - class(psb_c_base_sparse_mat), pointer :: amold - !Local variables - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - call psb_stringc2f(afmt,fafmt) - - ! Set the mold variable based on afmt - select case (psb_toupper(fafmt)) -#if defined(PSB_HAVE_CUDA) - case('ELG') - amold => aelg - case('HLG') - call psi_set_hksz(hksz) - amold => ahlg - case('CSRG') - amold => acsrg - case('ELL') - amold => aell - case('HLL') - call psi_set_hksz(hksz) - amold => ahll - case('CSR') - amold => acsr - case('CSC') - amold => acsc - case('DNS') - amold => adns - case default - write(*,*) 'Unknown format defaulting to HLG' - amold => ahlg -#else - case('ELL') - amold => aell - case('HLL') - call psi_set_hksz(hksz) - amold => ahll - amold => ahdia - case('CSR') - amold => acsr - case('CSC') - amold => acsc - case('DNS') - amold => adns - case default - write(*,*) 'Unknown format defaulting to CSR' - amold => acsr -#endif - end select - - select case(fafmt) -#if 0 -#ifdef PSB_HAVE_LIBRSB - case('RSB') - call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& - & upd=upd,mold=arsb) -#endif -#endif - case('ELL','HLL','CSR','DNS','CSC') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) -#if defined(PSB_HAVE_CUDA) - case('ELG','HLG','CSRG') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) -#endif - case default - write(psb_out_unit,*) 'psb_c_cspasb_opt: Unknown format ',fafmt - call psb_spasb(ap,descp,info,afmt=fafmt,upd=upd,dupl=dupl) - end select - - res = min(0,info) - - return - end function psb_c_cspasb_opt - - - function psb_c_cspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) - complex(c_float_complex) :: val(*) - type(psb_c_cspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - integer(psb_c_ipk_) :: ixb,info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) - else - call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) - end if - res = min(0,info) - return - end function psb_c_cspins - - - function psb_c_csprn(mh,cdh,clear) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - logical(c_bool), value :: clear - type(psb_c_cspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_cspmat_type), pointer :: ap - 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(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - fclear = clear - call psb_sprn(ap,descp,info,clear=fclear) - res = min(0,info) - - return - end function psb_c_csprn + interface + module function psb_c_cgeall(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_cgeall + end interface + + interface + module function psb_c_cgeall_remote(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + + end function psb_c_cgeall_remote + end interface + + interface + module function psb_c_cgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: dupl + integer(psb_c_ipk_), value :: bldmode + end function psb_c_cgeall_remote_options + end interface + + interface + module function psb_c_cgeasb(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_cgeasb + end interface + + interface + module function psb_c_cgeasb_options(xh,cdh,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: dupl + end function psb_c_cgeasb_options + end interface + + interface + module function psb_c_cgeasb_options_format(xh,cdh,dupl,format) bind(c) result(res) + ! Takes into account format argument as a c string, and uses it to call the appropriate psb_geasb + ! with mold argument + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + character(kind=c_char), dimension(*) :: format + integer(psb_c_ipk_), value :: dupl + end function psb_c_cgeasb_options_format + end interface + + interface + module function psb_c_cgefree(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_cgefree + end interface + + interface + module function psb_c_cgeins(nz,irw,val,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: nz + integer(psb_c_lpk_) :: irw(*) + complex(c_float_complex) :: val(*) + type(psb_c_cvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_cgeins + end interface + + interface + module function psb_c_cspall(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_cspall + end interface + + interface + module function psb_c_cspall_remote(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_cspall_remote + end interface + + interface + module function psb_c_cspasb(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_cspasb + end interface + + interface + module function psb_c_cspfree(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_cspfree + end interface + + interface + module function psb_c_cspasb_opt(mh,cdh,afmt,upd,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_cspmat) :: mh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: upd,dupl + character(c_char) :: afmt(*) + end function psb_c_cspasb_opt + end interface + + interface + module function psb_c_cspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: nz + integer(psb_c_lpk_) :: irw(*), icl(*) + complex(c_float_complex) :: val(*) + type(psb_c_cspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_cspins + end interface + + interface + module function psb_c_csprn(mh,cdh,clear) bind(c) result(res) + integer(psb_c_ipk_) :: res + logical(c_bool), value :: clear + type(psb_c_cspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_csprn + end interface !!$ -!!$ function psb_c_cspprint(mh) bind(c) result(res) +!!$ module function psb_c_cspprint(mh) bind(c) result(res) !!$ !!$ implicit none !!$ integer(psb_c_ipk_) :: res @@ -624,109 +165,32 @@ contains !!$ return !!$ end function psb_c_cspprint - function psb_c_cgetelem(xh,index,cdh) bind(c) result(res) - implicit none - - type(psb_c_cvector) :: xh - integer(psb_c_lpk_), value :: index - type(psb_c_descriptor) :: cdh - complex(c_float_complex) :: res - - type(psb_c_vect_type), pointer :: xp - 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(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - res = psb_getelem(xp,index,descp,info) - else - res = psb_getelem(xp,index+(1-ixb),descp,info) - end if - - return - - end function psb_c_cgetelem - - function psb_c_csetelem(index,val,xh,cdh) bind(c) result(res) - implicit none - - type(psb_c_cvector) :: xh - integer(psb_c_lpk_), value :: index - type(psb_c_descriptor) :: cdh - complex(c_float_complex), value :: val - integer(psb_c_ipk_) :: res - - type(psb_c_vect_type), pointer :: xp - 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(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_setelem(index,val,xp,descp,info) - else - call psb_setelem(index+(1-ixb),val,xp,descp,info) - end if - res=info - return - - end function psb_c_csetelem - - 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 + interface + module function psb_c_cgetelem(xh,index,cdh) bind(c) result(res) + type(psb_c_cvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + complex(c_float_complex) :: res + end function psb_c_cgetelem + end interface + + interface + module function psb_c_csetelem(index,val,xh,cdh) bind(c) result(res) + type(psb_c_cvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + complex(c_float_complex), value :: val + integer(psb_c_ipk_) :: res + end function psb_c_csetelem + end interface + + interface + module function psb_c_cmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) + type(psb_c_cspmat) :: ah + integer(psb_c_lpk_), value :: rowindex, colindex + type(psb_c_descriptor) :: cdh + complex(c_float_complex) :: res + end function psb_c_cmatgetelem + end interface end module psb_c_tools_cbind_mod diff --git a/cbind/base/psb_d_comm_cbind_mod.f90 b/cbind/base/psb_d_comm_cbind_mod.f90 index 49371e3a..31d0f732 100644 --- a/cbind/base/psb_d_comm_cbind_mod.f90 +++ b/cbind/base/psb_d_comm_cbind_mod.f90 @@ -3,236 +3,67 @@ module psb_d_comm_cbind_mod use psb_base_mod use psb_objhandle_mod -contains - - function psb_c_dovrl(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_ovrl(xp,descp,info) - - res = info - - end function psb_c_dovrl - - function psb_c_dovrl_opt(xh,cdh,update,mode) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: update, mode - - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_ovrl(xp,descp,info,update=update,mode=mode) - - res = info - - end function psb_c_dovrl_opt - - - function psb_c_dhalo(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_halo(xp,descp,info) - - res = info - - end function psb_c_dhalo - - function psb_c_dhalo_opt(xh,cdh,tran,data,mode) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: data, mode - character(c_char) :: tran - - - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - character :: ftran - integer(psb_c_ipk_) :: info - - - 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 - - ftran = tran - call psb_halo(xp,descp,info,data=data,mode=mode,tran=ftran) - - res = info - - end function psb_c_dhalo_opt - - - function psb_c_dvscatter(ng,gx,xh,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - integer(psb_c_lpk_), value :: ng - real(c_double), target :: gx(*) - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: vp - real(psb_dpk_), pointer :: pgx(:) - integer(psb_c_ipk_) :: info, sz - - 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,vp) - else - return - end if - - pgx => gx(1:ng) - - call psb_scatter(pgx,vp,descp,info) - res = info - - end function psb_c_dvscatter - - function psb_c_dvgather_f(v,xh,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - real(c_double), target :: v(*) - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: vp - real(psb_dpk_), allocatable :: fv(:) - integer(psb_c_ipk_) :: info, sz - - 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,vp) - else - return - end if - - call psb_gather(fv,vp,descp,info) - res = info - if (res /=0) return - sz = size(fv) - v(1:sz) = fv(1:sz) - end function psb_c_dvgather_f - - function psb_c_dspgather_f(gah,ah,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_dspmat) :: ah, gah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap, gap - integer(psb_c_ipk_) :: info, sz - - 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 - if (c_associated(gah%item)) then - call c_f_pointer(gah%item,gap) - else - return - end if - call psb_gather(gap,ap,descp,info) - res = info - end function psb_c_dspgather_f - + interface + module function psb_c_dovrl(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dovrl + end interface + + interface + module function psb_c_dovrl_opt(xh,cdh,update,mode) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: update, mode + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dovrl_opt + end interface + + + interface + module function psb_c_dhalo(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dhalo + end interface + + interface + module function psb_c_dhalo_opt(xh,cdh,tran,data,mode) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: data, mode + character(c_char) :: tran + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dhalo_opt + end interface + + interface + module function psb_c_dvscatter(ng,gx,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_lpk_), value :: ng + real(c_double), target :: gx(*) + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dvscatter + end interface + + interface + module function psb_c_dvgather_f(v,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + real(c_double), target :: v(*) + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dvgather_f + end interface + + interface + module function psb_c_dspgather_f(gah,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: ah, gah + type(psb_c_descriptor) :: cdh + end function psb_c_dspgather_f + end interface + end module psb_d_comm_cbind_mod diff --git a/cbind/base/psb_d_psblas_cbind_mod.f90 b/cbind/base/psb_d_psblas_cbind_mod.f90 index 1a8874c5..ce960f3e 100644 --- a/cbind/base/psb_d_psblas_cbind_mod.f90 +++ b/cbind/base/psb_d_psblas_cbind_mod.f90 @@ -3,1366 +3,352 @@ module psb_d_psblas_cbind_mod use psb_base_mod use psb_objhandle_mod -contains - function psb_c_dgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - real(c_double), value :: alpha,beta - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geaxpby(alpha,xp,beta,yp,descp,info) - - res = info - - end function psb_c_dgeaxpby - - function psb_c_dgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - real(c_double), value :: alpha,beta - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_geaxpby(alpha,xp,beta,yp,zp,descp,info) - - res = info - - end function psb_c_dgeaxpbyz - - function psb_c_dgemlt(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_gemlt(xp,yp,descp,info) - - res = info - - end function psb_c_dgemlt - - function psb_c_dgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh, zh - type(psb_c_descriptor) :: cdh - - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - real(psb_dpk_), intent(in), value :: alpha,beta - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) - - res = info - - end function psb_c_dgemlt2 - - function psb_c_dgediv(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_gediv(xp,yp,descp,info) - - res = info - - end function psb_c_dgediv - - function psb_c_dgediv2(xh,yh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gediv(xp,yp,zp,descp,info) - - res = info - - end function psb_c_dgediv2 - - function psb_c_dgediv_check(xh,yh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - fflag = flag - call psb_gediv(xp,yp,descp,info,fflag) - - res = info - - end function psb_c_dgediv_check - - function psb_c_dgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - fflag = flag - call psb_gediv(xp,yp,zp,descp,info,fflag) - - res = info - - end function psb_c_dgediv2_check - - function psb_c_dgeinv(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geinv(xp,yp,descp,info) - - res = info - - end function psb_c_dgeinv - - function psb_c_dgeinv_check(xh,yh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - fflag = flag - call psb_geinv(xp,yp,descp,info,fflag) - - res = info - - end function psb_c_dgeinv_check - - function psb_c_dgeabs(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geabs(xp,yp,descp,info) - - res = info - - end function psb_c_dgeabs - - function psb_c_dgecmp(xh,ch,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - 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 - - 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 - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gecmp(xp,ch,zp,descp,info) - - res = info - - end function psb_c_dgecmp - - function psb_c_dgecmpmat(ah,bh,tol,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_dspmat) :: ah,bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - real(c_double), value :: tol - logical :: isequal - - res = .false. - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call psb_gecmp(ap,bp,tol,descp,isequal,info) - - res = isequal - - end function psb_c_dgecmpmat - - function psb_c_dgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - real(c_double), value :: val - real(c_double), value :: tol - logical :: isequal - - res = .false. - - 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 - - call psb_gecmp(ap,val,tol,descp,isequal,info) - - res = isequal - - end function psb_c_dgecmpmat_val - - function psb_c_dgeaddconst(xh,bh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - 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 :: bh - - 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 - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_geaddconst(xp,bh,zp,descp,info) - - res = info - - end function psb_c_dgeaddconst - - function psb_c_dmask(ch,xh,mh,t,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dvector) :: ch,xh,mh - type(psb_c_descriptor) :: cdh - logical(c_bool) :: t - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: cp,xp,mp - integer(psb_c_ipk_) :: info - logical :: fp - - res = -1 - - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(ch%item)) then - call c_f_pointer(ch%item,cp) - else - return - end if - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,mp) - else - return - end if - - call psb_mask(cp,xp,mp,fp,descp,info) - - t = fp - res = info - - end function psb_c_dmask - - function psb_c_dminquotient(xh,yh,cdh) bind(c) result(res) - implicit none - real(psb_dpk_) :: res - - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - res = psb_minquotient(xp,yp,descp,info) - - - end function psb_c_dminquotient - - function psb_c_dgenrm2(xh,cdh) bind(c) result(res) - implicit none - real(c_double) :: res - - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - res = psb_genrm2(xp,descp,info) - - end function psb_c_dgenrm2 - - function psb_c_dgenrmi(xh,cdh) bind(c) result(res) - implicit none - real(c_double) :: res - - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - type(psb_d_vect_type) :: yp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - call psb_geall(yp,descp,info) - call psb_geabs(xp,yp,descp,info) - res = psb_geasum(yp,descp,info) - call psb_gefree(yp,descp,info) - - end function psb_c_dgenrmi - - function psb_c_dgenrm2_weight(xh,wh,cdh) bind(c) result(res) - implicit none - real(c_double) :: res - - type(psb_c_dvector) :: xh, wh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp, wp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - if (c_associated(wh%item)) then - call c_f_pointer(wh%item,wp) - else - return - end if - - res = psb_genrm2(xp,wp,descp,info) - - end function psb_c_dgenrm2_weight - - function psb_c_dgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) - implicit none - real(c_double) :: res - - type(psb_c_dvector) :: xh, wh, idvh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp, wp, idvp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - if (c_associated(wh%item)) then - call c_f_pointer(wh%item,wp) - else - return - end if - if (c_associated(idvh%item)) then - call c_f_pointer(idvh%item,idvp) - else - return - end if - - res = psb_genrm2(xp,wp,idvp,descp,info) - - end function psb_c_dgenrm2_weightmask - - function psb_c_dgeamax(xh,cdh) bind(c) result(res) - implicit none - real(c_double) :: res - - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - - res = psb_geamax(xp,descp,info) - - end function psb_c_dgeamax - - function psb_c_dgemin(xh,cdh) bind(c) result(res) - implicit none - real(c_double) :: res - - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - - res = psb_gemin(xp,descp,info) - - end function psb_c_dgemin - - function psb_c_dgeasum(xh,cdh) bind(c) result(res) - implicit none - real(c_double) :: res - - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - res = psb_geasum(xp,descp,info) - - end function psb_c_dgeasum - - - function psb_c_dspnrmi(ah,cdh) bind(c) result(res) - implicit none - real(c_double) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - - res = psb_spnrmi(ap,descp,info) - - end function psb_c_dspnrmi - - function psb_c_dgedot(xh,yh,cdh) bind(c) result(res) - implicit none - real(c_double) :: res - - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - res = psb_gedot(xp,yp,descp,info) - - end function psb_c_dgedot - - - function psb_c_dspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - real(c_double), value :: alpha, beta - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - call psb_spmm(alpha,ap,xp,beta,yp,descp,info) - - res = info - - end function psb_c_dspmm - - - function psb_c_dspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - real(c_double), value :: alpha, beta - character(c_char) :: trans - logical(c_bool), value :: doswap - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - type(psb_dspmat_type), pointer :: ap - character :: ftrans - logical :: fdoswap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - fdoswap = doswap - ftrans = trans - call psb_spmm(alpha,ap,xp,beta,yp,descp,info,trans=ftrans,doswap=fdoswap) - - res = info - - end function psb_c_dspmm_opt - - - function psb_c_dspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_dvector) :: xh,yh - type(psb_c_descriptor) :: cdh - real(c_double), value :: alpha, beta - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp,yp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - call psb_spsm(alpha,ap,xp,beta,yp,descp,info) - - res = info - - end function psb_c_dspsm - - function psb_c_dnnz(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - - 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 - - res = psb_nnz(ap,descp,info) - - end function psb_c_dnnz - - function psb_c_dis_matupd(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_upd() - end function - - function psb_c_dis_matasb(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_asb() - end function - - function psb_c_dis_matbld(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_bld() - end function - - function psb_c_dset_matupd(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - - 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 - - call ap%set_upd() - - res = psb_success_ - end function - - function psb_c_dset_matasb(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - - 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 - - call ap%set_asb() - - res = psb_success_ - - end function - - function psb_c_dset_matbld(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - - 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 - - call ap%set_bld() - - res = psb_success_ - end function - - function psb_c_dcopy_mat(ah,bh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dspmat) :: ah,bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call ap%clone(bp,info) - - res = info - end function - - function psb_c_dspscal(alpha,ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - real(c_double), value :: alpha - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - - call ap%scal(alpha,info) - - res = info - - end function psb_c_dspscal - - function psb_c_dspscalpid(alpha,ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - real(c_double), value :: alpha - type(psb_c_dspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - - call ap%scalpid(alpha,info) - - res = info - - end function psb_c_dspscalpid - - function psb_c_dspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - real(c_double), value :: alpha - type(psb_c_dspmat) :: ah - real(c_double), value :: beta - type(psb_c_dspmat) :: bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call ap%spaxpby(alpha,beta,bp,info) - - res = info - end function psb_c_dspaxpby + interface + module function psb_c_dgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + real(c_double), value :: alpha,beta + end function psb_c_dgeaxpby + end interface + + interface + module function psb_c_dgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + real(c_double), value :: alpha,beta + end function psb_c_dgeaxpbyz + end interface + + interface + module function psb_c_dgemlt(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_dgemlt + end interface + + interface + module function psb_c_dgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + real(psb_dpk_), intent(in), value :: alpha,beta + end function psb_c_dgemlt2 + end interface + + interface + module function psb_c_dgediv(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_dgediv + end interface + + interface + module function psb_c_dgediv2(xh,yh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + end function psb_c_dgediv2 + end interface + + interface + module function psb_c_dgediv_check(xh,yh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_dgediv_check + end interface + + interface + module function psb_c_dgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_dgediv2_check + end interface + + interface + module function psb_c_dgeinv(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_dgeinv + end interface + + interface + module function psb_c_dgeinv_check(xh,yh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_dgeinv_check + end interface + + interface + module function psb_c_dgeabs(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_dgeabs + end interface + + interface + module function psb_c_dgecmp(xh,ch,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,zh + type(psb_c_descriptor) :: cdh + real(c_double), value :: ch + end function psb_c_dgecmp + end interface + + interface + module function psb_c_dgecmpmat(ah,bh,tol,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_dspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + real(c_double), value :: tol + end function psb_c_dgecmpmat + end interface + + interface + module function psb_c_dgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + real(c_double), value :: val + real(c_double), value :: tol + end function psb_c_dgecmpmat_val + end interface + + interface + module function psb_c_dgeaddconst(xh,bh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh,zh + type(psb_c_descriptor) :: cdh + real(c_double), value :: bh + end function psb_c_dgeaddconst + end interface + + interface + module function psb_c_dmask(ch,xh,mh,t,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: ch,xh,mh + type(psb_c_descriptor) :: cdh + logical(c_bool) :: t + end function psb_c_dmask + end interface + + interface + module function psb_c_dminquotient(xh,yh,cdh) bind(c) result(res) + real(psb_dpk_) :: res + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_dminquotient + end interface + + interface + module function psb_c_dgenrm2(xh,cdh) bind(c) result(res) + real(c_double) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dgenrm2 + end interface + + interface + module function psb_c_dgenrmi(xh,cdh) bind(c) result(res) + real(c_double) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dgenrmi + end interface + + interface + module function psb_c_dgenrm2_weight(xh,wh,cdh) bind(c) result(res) + real(c_double) :: res + type(psb_c_dvector) :: xh, wh + type(psb_c_descriptor) :: cdh + end function psb_c_dgenrm2_weight + end interface + + interface + module function psb_c_dgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) + real(c_double) :: res + type(psb_c_dvector) :: xh, wh, idvh + type(psb_c_descriptor) :: cdh + end function psb_c_dgenrm2_weightmask + end interface + + interface + module function psb_c_dgeamax(xh,cdh) bind(c) result(res) + real(c_double) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dgeamax + end interface + + interface + module function psb_c_dgemin(xh,cdh) bind(c) result(res) + real(c_double) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dgemin + end interface + + interface + module function psb_c_dgeasum(xh,cdh) bind(c) result(res) + real(c_double) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dgeasum + end interface + + interface + module function psb_c_dspnrmi(ah,cdh) bind(c) result(res) + real(c_double) :: res + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_dspnrmi + end interface + + interface + module function psb_c_dgedot(xh,yh,cdh) bind(c) result(res) + real(c_double) :: res + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_dgedot + end interface + + interface + module function psb_c_dspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: ah + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + real(c_double), value :: alpha, beta + end function psb_c_dspmm + end interface + + interface + module function psb_c_dspmm_opt(alpha,ah,xh,beta,yh,& + & cdh,trans,doswap) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: ah + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + real(c_double), value :: alpha, beta + character(c_char) :: trans + logical(c_bool), value :: doswap + end function psb_c_dspmm_opt + end interface + + interface + module function psb_c_dspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: ah + type(psb_c_dvector) :: xh,yh + type(psb_c_descriptor) :: cdh + real(c_double), value :: alpha, beta + type(psb_desc_type), pointer :: descp + end function psb_c_dspsm + end interface + + interface + module function psb_c_dnnz(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_dnnz + end interface + + interface + module function psb_c_dis_matupd(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_dis_matasb(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_dis_matbld(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_dset_matupd(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_dset_matasb(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_dset_matbld(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_dcopy_mat(ah,bh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_dspscal(alpha,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + real(c_double), value :: alpha + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_dspscal + end interface + + interface + module function psb_c_dspscalpid(alpha,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + real(c_double), value :: alpha + type(psb_c_dspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_dspscalpid + end interface + + interface + module function psb_c_dspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + real(c_double), value :: alpha + type(psb_c_dspmat) :: ah + real(c_double), value :: beta + type(psb_c_dspmat) :: bh + type(psb_c_descriptor) :: cdh + end function psb_c_dspaxpby + end interface end module psb_d_psblas_cbind_mod diff --git a/cbind/base/psb_d_serial_cbind_mod.F90 b/cbind/base/psb_d_serial_cbind_mod.F90 index 4cea1d23..189df9ec 100644 --- a/cbind/base/psb_d_serial_cbind_mod.F90 +++ b/cbind/base/psb_d_serial_cbind_mod.F90 @@ -4,294 +4,110 @@ module psb_d_serial_cbind_mod use psb_objhandle_mod use psb_base_tools_cbind_mod -contains - - function psb_c_dvect_get_nrows(xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_dvector) :: xh - - type(psb_d_vect_type), pointer :: vp - integer(psb_c_ipk_) :: info - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - res = vp%get_nrows() - end if - - end function psb_c_dvect_get_nrows - - function psb_c_dvect_f_get_cpy(v,xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - real(c_double) :: v(*) - type(psb_c_dvector) :: xh - - type(psb_d_vect_type), pointer :: vp - real(psb_dpk_), allocatable :: fv(:) - integer(psb_c_ipk_) :: info, sz - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - fv = vp%get_vect() - sz = size(fv) - v(1:sz) = fv(1:sz) - end if - - end function psb_c_dvect_f_get_cpy - - - function psb_c_dvect_zero(xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_dvector) :: xh - - type(psb_d_vect_type), pointer :: vp - integer(psb_c_ipk_) :: info - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - call vp%zero() - end if - - end function psb_c_dvect_zero - - function psb_c_dvect_f_get_pnt(xh) bind(c) result(res) - implicit none - - type(c_ptr) :: res - type(psb_c_dvector) :: xh - - type(psb_d_vect_type), pointer :: vp - - res = c_null_ptr - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - if(vp%is_dev()) call vp%sync() - res = c_loc(vp%v%v) - end if - - end function psb_c_dvect_f_get_pnt - - - function psb_c_dmat_get_nrows(mh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dspmat) :: mh - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - res = ap%get_nrows() - - end function psb_c_dmat_get_nrows - - - function psb_c_dmat_get_ncols(mh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_dspmat) :: mh - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - res = ap%get_ncols() - - end function psb_c_dmat_get_ncols - - - function psb_c_dmat_name_print(mh,name) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - character(c_char) :: name(*) - type(psb_c_dspmat) :: mh - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - character(1024) :: fname - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - call psb_stringc2f(name,fname) - - call ap%print(fname,head='PSBLAS Cbinding Interface') - - end function psb_c_dmat_name_print - - function psb_c_dvect_set_scal(x,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 - real(c_double), value :: val - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val) - - info = 0 - - end function psb_c_dvect_set_scal - - function psb_c_dvect_set_scal_bound(x,val,ifirst,ilast) 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 :: ifirst, ilast - real(c_double) :: val - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val,first=ifirst,last=ilast) - - info = 0 - - end function psb_c_dvect_set_scal_bound - - function psb_c_dvect_set_vect(x,val,n) 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 :: n - real(c_double) :: val(*) - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val(1:n)) - - info = 0 - - 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 + interface + module function psb_c_dvect_get_nrows(xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + + type(psb_d_vect_type), pointer :: vp + integer(psb_c_ipk_) :: info + end function psb_c_dvect_get_nrows + end interface + + interface + module function psb_c_dvect_f_get_cpy(v,xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + real(c_double) :: v(*) + type(psb_c_dvector) :: xh + end function psb_c_dvect_f_get_cpy + end interface + + + interface + module function psb_c_dvect_zero(xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + end function psb_c_dvect_zero + end interface + + interface + module function psb_c_dvect_f_get_pnt(xh) bind(c) result(res) + type(c_ptr) :: res + type(psb_c_dvector) :: xh + end function psb_c_dvect_f_get_pnt + end interface + + interface + module function psb_c_dmat_get_nrows(mh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: mh + end function psb_c_dmat_get_nrows + end interface + + interface + module function psb_c_dmat_get_ncols(mh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: mh + end function psb_c_dmat_get_ncols + end interface + + interface + module function psb_c_dmat_name_print(mh,name) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: mh + character(c_char) :: name(*) + end function psb_c_dmat_name_print + end interface + + interface + module function psb_c_dvect_set_scal(x,val) bind(c) result(info) + type(psb_c_dvector) :: x + integer(psb_c_ipk_) :: info + real(c_double), value :: val + end function psb_c_dvect_set_scal + end interface + + interface + module function psb_c_dvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + type(psb_c_dvector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + real(c_double) :: val + end function psb_c_dvect_set_scal_bound + end interface + + interface + module function psb_c_dvect_set_vect(x,val,n) bind(c) result(info) + type(psb_c_dvector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: n + real(c_double) :: val(*) + end function psb_c_dvect_set_vect + end interface + + interface + module function psb_c_dvect_set_entry(x,index,val) bind(c) result(info) + type(psb_c_dvector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + real(c_double), value :: val + end function psb_c_dvect_set_entry + end interface - 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() - write(0,*) 'C_get_entry: ',index,(index+(1-ixb)) - 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 - - integer(psb_c_ipk_) :: info - type(psb_c_dvector) :: xh,yh - - type(psb_d_vect_type), pointer :: xp,yp - - info = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - call xp%clone(yp,info) - - end function psb_c_dvect_clone + interface + module function psb_c_dvect_get_entry(x,index) bind(c) result(res) + type(psb_c_dvector) :: x + integer(psb_c_ipk_), value :: index + real(c_double) :: res + end function psb_c_dvect_get_entry + end interface + + interface + module function psb_c_dvect_clone(xh,yh) bind(c) result(info) + integer(psb_c_ipk_) :: info + type(psb_c_dvector) :: xh,yh + end function psb_c_dvect_clone + end interface end module psb_d_serial_cbind_mod diff --git a/cbind/base/psb_d_tools_cbind_mod.F90 b/cbind/base/psb_d_tools_cbind_mod.F90 index 2dfd372b..101e2af7 100644 --- a/cbind/base/psb_d_tools_cbind_mod.F90 +++ b/cbind/base/psb_d_tools_cbind_mod.F90 @@ -8,614 +8,145 @@ module psb_d_tools_cbind_mod use psb_cuda_mod #endif -contains - ! Should define geall_opt with DUPL argument - function psb_c_dgeall(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_dgeall - - function psb_c_dgeall_remote(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info,bldmode=psb_matbld_remote_,dupl=psb_dupl_add_) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_dgeall_remote - - function psb_c_dgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: dupl - integer(psb_c_ipk_), value :: bldmode - - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info,bldmode=bldmode,dupl=dupl) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_dgeall_remote_options - - function psb_c_dgeasb(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_geasb(xp,descp,info) - res = min(0,info) - - return - end function psb_c_dgeasb - - function psb_c_dgeasb_options(xh,cdh,dupl) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: dupl - - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_geasb(xp,descp,info,dupl=dupl) - res = min(0,info) - - return - end function psb_c_dgeasb_options - - function psb_c_dgeasb_options_format(xh,cdh,dupl,format) bind(c) result(res) - ! Takes into account format argument as a c string, and uses it to call the appropriate psb_geasb - ! with mold argument - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - character(kind=c_char), dimension(*) :: format - integer(psb_c_ipk_), value :: dupl - - ! Local variables - character(len=6) :: fformat - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - ! mold variables -#ifdef PSB_HAVE_CUDA - type(psb_d_vect_cuda), target :: vgpu -#endif - type(psb_d_base_vect_type), target :: vect - class(psb_d_base_vect_type), pointer :: vmold - - ! Select mold based on format - call psb_stringc2f(format,fformat) - - select case (psb_toupper(fformat)) -#ifdef PSB_HAVE_CUDA - case('GPU','DEVICE') - vmold => vgpu -#endif - case('CPU','HOST') - vmold => vect - case default - write(psb_out_unit,*) 'psb_c_dgeasb_options_format: Unknown format ',fformat - vmold => vect - end select - 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 - - call psb_geasb(xp,descp,info,dupl=dupl,mold=vmold) - res = min(0,info) - - return - end function psb_c_dgeasb_options_format - - - function psb_c_dgefree(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_gefree(xp,descp,info) - res = min(0,info) - deallocate(xp,stat=info) - res = min(0,info) - xh%item = c_null_ptr - - return - end function psb_c_dgefree - - - function psb_c_dgeins(nz,irw,val,xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*) - real(c_double) :: val(*) - type(psb_c_dvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: ixb, info - - res = -1 - info = 0 - 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 - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_geins(nz,irw(1:nz),val(1:nz),& - & xp,descp,info) - else - call psb_geins(nz,(irw(1:nz)+(1-ixb)),val(1:nz),& - & xp,descp,info) - end if - - res = min(0,info) - - return - end function psb_c_dgeins - - function psb_c_dspall(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - return - end if - allocate(ap) - call psb_spall(ap,descp,info) - mh%item = c_loc(ap) - res = min(0,info) - - return - end function psb_c_dspall - - - function psb_c_dspall_remote(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - return - end if - allocate(ap) - call psb_spall(ap,descp,info,bldmode=psb_matbld_remote_,dupl=psb_dupl_add_) - mh%item = c_loc(ap) - res = min(0,info) - - return - end function psb_c_dspall_remote - - function psb_c_dspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - call psb_spasb(ap,descp,info) - res = min(0,info) - return - end function psb_c_dspasb - - function psb_c_dspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - call psb_spfree(ap,descp,info) - res = min(0,info) - deallocate(ap,stat=info) - mh%item=c_null_ptr - return - end function psb_c_dspfree - - - - - function psb_c_dspasb_opt(mh,cdh,afmt,upd,dupl) bind(c) result(res) - -#if 0 -#ifdef PSB_HAVE_LIBRSB - use psb_d_rsb_mat_mod -#endif -#endif -#if defined(PSB_HAVE_CUDA) - use psb_cuda_mod -#endif - use psb_ext_mod - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_dspmat) :: mh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: upd,dupl - character(c_char) :: afmt(*) - integer(psb_c_ipk_) :: info,n - character(len=5) :: fafmt - integer(psb_ipk_), parameter :: hksz = 32 - ! mold variables -#if 0 -#ifdef PSB_HAVE_LIBRSB - type(psb_d_rsb_sparse_mat) :: arsb -#endif -#endif - type(psb_d_ell_sparse_mat), target :: aell - type(psb_d_csr_sparse_mat), target :: acsr - type(psb_d_csc_sparse_mat), target :: acsc - type(psb_d_coo_sparse_mat), target :: acoo - type(psb_d_hll_sparse_mat), target :: ahll - type(psb_d_hdia_sparse_mat), target :: ahdia - type(psb_d_dns_sparse_mat), target :: adns -#if defined(PSB_HAVE_CUDA) - type(psb_d_cuda_hlg_sparse_mat), target :: ahlg - type(psb_d_cuda_hdiag_sparse_mat), target :: ahdiag - type(psb_d_cuda_csrg_sparse_mat), target :: acsrg - type(psb_d_cuda_elg_sparse_mat), target :: aelg -#endif - class(psb_d_base_sparse_mat), pointer :: amold - !Local variables - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - call psb_stringc2f(afmt,fafmt) - - ! Set the mold variable based on afmt - select case (psb_toupper(fafmt)) -#if defined(PSB_HAVE_CUDA) - case('ELG') - amold => aelg - case('HLG') - call psi_set_hksz(hksz) - amold => ahlg - case('HDIAG') - amold => ahdiag - case('CSRG') - amold => acsrg - case('ELL') - amold => aell - case('HLL') - call psi_set_hksz(hksz) - amold => ahll - case('HDIA') - amold => ahdia - case('CSR') - amold => acsr - case('CSC') - amold => acsc - case('DNS') - amold => adns - case default - write(*,*) 'Unknown format defaulting to HLG' - amold => ahlg -#else - case('ELL') - amold => aell - case('HLL') - call psi_set_hksz(hksz) - amold => ahll - case('HDIA') - amold => ahdia - case('CSR') - amold => acsr - case('CSC') - amold => acsc - case('DNS') - amold => adns - case default - write(*,*) 'Unknown format defaulting to CSR' - amold => acsr -#endif - end select - - select case(fafmt) -#if 0 -#ifdef PSB_HAVE_LIBRSB - case('RSB') - call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& - & upd=upd,mold=arsb) -#endif -#endif - case('ELL','HLL','CSR','DNS','CSC') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) - case('HDIA') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) -#if defined(PSB_HAVE_CUDA) - case('ELG','HLG','CSRG') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) - case('HDIAG') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) -#endif - case default - write(psb_out_unit,*) 'psb_c_dspasb_opt: Unknown format ',fafmt - call psb_spasb(ap,descp,info,afmt=fafmt,upd=upd,dupl=dupl) - end select - - res = min(0,info) - - return - end function psb_c_dspasb_opt - - - function psb_c_dspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) - real(c_double) :: val(*) - type(psb_c_dspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - integer(psb_c_ipk_) :: ixb,info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) - else - call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) - end if - res = min(0,info) - return - end function psb_c_dspins - - - function psb_c_dsprn(mh,cdh,clear) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - logical(c_bool), value :: clear - type(psb_c_dspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_dspmat_type), pointer :: ap - 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(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - fclear = clear - call psb_sprn(ap,descp,info,clear=fclear) - res = min(0,info) - - return - end function psb_c_dsprn + interface + module function psb_c_dgeall(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dgeall + end interface + + interface + module function psb_c_dgeall_remote(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + + end function psb_c_dgeall_remote + end interface + + interface + module function psb_c_dgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: dupl + integer(psb_c_ipk_), value :: bldmode + end function psb_c_dgeall_remote_options + end interface + + interface + module function psb_c_dgeasb(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dgeasb + end interface + + interface + module function psb_c_dgeasb_options(xh,cdh,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: dupl + end function psb_c_dgeasb_options + end interface + + interface + module function psb_c_dgeasb_options_format(xh,cdh,dupl,format) bind(c) result(res) + ! Takes into account format argument as a c string, and uses it to call the appropriate psb_geasb + ! with mold argument + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + character(kind=c_char), dimension(*) :: format + integer(psb_c_ipk_), value :: dupl + end function psb_c_dgeasb_options_format + end interface + + interface + module function psb_c_dgefree(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dgefree + end interface + + interface + module function psb_c_dgeins(nz,irw,val,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: nz + integer(psb_c_lpk_) :: irw(*) + real(c_double) :: val(*) + type(psb_c_dvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_dgeins + end interface + + interface + module function psb_c_dspall(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_dspall + end interface + + interface + module function psb_c_dspall_remote(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_dspall_remote + end interface + + interface + module function psb_c_dspasb(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_dspasb + end interface + + interface + module function psb_c_dspfree(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_dspfree + end interface + + interface + module function psb_c_dspasb_opt(mh,cdh,afmt,upd,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_dspmat) :: mh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: upd,dupl + character(c_char) :: afmt(*) + end function psb_c_dspasb_opt + end interface + + interface + module function psb_c_dspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: nz + integer(psb_c_lpk_) :: irw(*), icl(*) + real(c_double) :: val(*) + type(psb_c_dspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_dspins + end interface + + interface + module function psb_c_dsprn(mh,cdh,clear) bind(c) result(res) + integer(psb_c_ipk_) :: res + logical(c_bool), value :: clear + type(psb_c_dspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_dsprn + end interface !!$ -!!$ function psb_c_dspprint(mh) bind(c) result(res) +!!$ module function psb_c_dspprint(mh) bind(c) result(res) !!$ !!$ implicit none !!$ integer(psb_c_ipk_) :: res @@ -634,109 +165,32 @@ contains !!$ return !!$ end function psb_c_dspprint - function psb_c_dgetelem(xh,index,cdh) bind(c) result(res) - implicit none - - type(psb_c_dvector) :: xh - integer(psb_c_lpk_), value :: index - type(psb_c_descriptor) :: cdh - real(c_double) :: res - - type(psb_d_vect_type), pointer :: xp - 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(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - res = psb_getelem(xp,index,descp,info) - else - res = psb_getelem(xp,index+(1-ixb),descp,info) - end if - - return - - end function psb_c_dgetelem - - function psb_c_dsetelem(index,val,xh,cdh) bind(c) result(res) - implicit none - - type(psb_c_dvector) :: xh - integer(psb_c_lpk_), value :: index - type(psb_c_descriptor) :: cdh - real(c_double), value :: val - integer(psb_c_ipk_) :: res - - type(psb_d_vect_type), pointer :: xp - 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(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_setelem(index,val,xp,descp,info) - else - call psb_setelem(index+(1-ixb),val,xp,descp,info) - end if - res=info - return - - end function psb_c_dsetelem - - 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 + interface + module function psb_c_dgetelem(xh,index,cdh) bind(c) result(res) + type(psb_c_dvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + real(c_double) :: res + end function psb_c_dgetelem + end interface + + interface + module function psb_c_dsetelem(index,val,xh,cdh) bind(c) result(res) + type(psb_c_dvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + real(c_double), value :: val + integer(psb_c_ipk_) :: res + end function psb_c_dsetelem + end interface + + interface + module function psb_c_dmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) + type(psb_c_dspmat) :: ah + integer(psb_c_lpk_), value :: rowindex, colindex + type(psb_c_descriptor) :: cdh + real(c_double) :: res + end function psb_c_dmatgetelem + end interface end module psb_d_tools_cbind_mod diff --git a/cbind/base/psb_s_comm_cbind_mod.f90 b/cbind/base/psb_s_comm_cbind_mod.f90 index c63d3ffb..726f7c54 100644 --- a/cbind/base/psb_s_comm_cbind_mod.f90 +++ b/cbind/base/psb_s_comm_cbind_mod.f90 @@ -3,236 +3,67 @@ module psb_s_comm_cbind_mod use psb_base_mod use psb_objhandle_mod -contains - - function psb_c_sovrl(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_ovrl(xp,descp,info) - - res = info - - end function psb_c_sovrl - - function psb_c_sovrl_opt(xh,cdh,update,mode) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: update, mode - - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_ovrl(xp,descp,info,update=update,mode=mode) - - res = info - - end function psb_c_sovrl_opt - - - function psb_c_shalo(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_halo(xp,descp,info) - - res = info - - end function psb_c_shalo - - function psb_c_shalo_opt(xh,cdh,tran,data,mode) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: data, mode - character(c_char) :: tran - - - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - character :: ftran - integer(psb_c_ipk_) :: info - - - 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 - - ftran = tran - call psb_halo(xp,descp,info,data=data,mode=mode,tran=ftran) - - res = info - - end function psb_c_shalo_opt - - - function psb_c_svscatter(ng,gx,xh,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - integer(psb_c_lpk_), value :: ng - real(c_float), target :: gx(*) - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: vp - real(psb_spk_), pointer :: pgx(:) - integer(psb_c_ipk_) :: info, sz - - 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,vp) - else - return - end if - - pgx => gx(1:ng) - - call psb_scatter(pgx,vp,descp,info) - res = info - - end function psb_c_svscatter - - function psb_c_svgather_f(v,xh,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - real(c_float), target :: v(*) - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: vp - real(psb_spk_), allocatable :: fv(:) - integer(psb_c_ipk_) :: info, sz - - 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,vp) - else - return - end if - - call psb_gather(fv,vp,descp,info) - res = info - if (res /=0) return - sz = size(fv) - v(1:sz) = fv(1:sz) - end function psb_c_svgather_f - - function psb_c_sspgather_f(gah,ah,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_sspmat) :: ah, gah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap, gap - integer(psb_c_ipk_) :: info, sz - - 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 - if (c_associated(gah%item)) then - call c_f_pointer(gah%item,gap) - else - return - end if - call psb_gather(gap,ap,descp,info) - res = info - end function psb_c_sspgather_f - + interface + module function psb_c_sovrl(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sovrl + end interface + + interface + module function psb_c_sovrl_opt(xh,cdh,update,mode) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: update, mode + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sovrl_opt + end interface + + + interface + module function psb_c_shalo(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_shalo + end interface + + interface + module function psb_c_shalo_opt(xh,cdh,tran,data,mode) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: data, mode + character(c_char) :: tran + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_shalo_opt + end interface + + interface + module function psb_c_svscatter(ng,gx,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_lpk_), value :: ng + real(c_float), target :: gx(*) + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_svscatter + end interface + + interface + module function psb_c_svgather_f(v,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + real(c_float), target :: v(*) + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_svgather_f + end interface + + interface + module function psb_c_sspgather_f(gah,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: ah, gah + type(psb_c_descriptor) :: cdh + end function psb_c_sspgather_f + end interface + end module psb_s_comm_cbind_mod diff --git a/cbind/base/psb_s_psblas_cbind_mod.f90 b/cbind/base/psb_s_psblas_cbind_mod.f90 index eeabfdbc..6c7004ab 100644 --- a/cbind/base/psb_s_psblas_cbind_mod.f90 +++ b/cbind/base/psb_s_psblas_cbind_mod.f90 @@ -3,1366 +3,352 @@ module psb_s_psblas_cbind_mod use psb_base_mod use psb_objhandle_mod -contains - function psb_c_sgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - real(c_float), value :: alpha,beta - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geaxpby(alpha,xp,beta,yp,descp,info) - - res = info - - end function psb_c_sgeaxpby - - function psb_c_sgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - real(c_float), value :: alpha,beta - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_geaxpby(alpha,xp,beta,yp,zp,descp,info) - - res = info - - end function psb_c_sgeaxpbyz - - function psb_c_sgemlt(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_gemlt(xp,yp,descp,info) - - res = info - - end function psb_c_sgemlt - - function psb_c_sgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh, zh - type(psb_c_descriptor) :: cdh - - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - real(psb_spk_), intent(in), value :: alpha,beta - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) - - res = info - - end function psb_c_sgemlt2 - - function psb_c_sgediv(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_gediv(xp,yp,descp,info) - - res = info - - end function psb_c_sgediv - - function psb_c_sgediv2(xh,yh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gediv(xp,yp,zp,descp,info) - - res = info - - end function psb_c_sgediv2 - - function psb_c_sgediv_check(xh,yh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - fflag = flag - call psb_gediv(xp,yp,descp,info,fflag) - - res = info - - end function psb_c_sgediv_check - - function psb_c_sgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - fflag = flag - call psb_gediv(xp,yp,zp,descp,info,fflag) - - res = info - - end function psb_c_sgediv2_check - - function psb_c_sgeinv(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geinv(xp,yp,descp,info) - - res = info - - end function psb_c_sgeinv - - function psb_c_sgeinv_check(xh,yh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - fflag = flag - call psb_geinv(xp,yp,descp,info,fflag) - - res = info - - end function psb_c_sgeinv_check - - function psb_c_sgeabs(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geabs(xp,yp,descp,info) - - res = info - - end function psb_c_sgeabs - - function psb_c_sgecmp(xh,ch,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - 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 - - 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 - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gecmp(xp,ch,zp,descp,info) - - res = info - - end function psb_c_sgecmp - - function psb_c_sgecmpmat(ah,bh,tol,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_sspmat) :: ah,bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - real(c_float), value :: tol - logical :: isequal - - res = .false. - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call psb_gecmp(ap,bp,tol,descp,isequal,info) - - res = isequal - - end function psb_c_sgecmpmat - - function psb_c_sgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - real(c_float), value :: val - real(c_float), value :: tol - logical :: isequal - - res = .false. - - 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 - - call psb_gecmp(ap,val,tol,descp,isequal,info) - - res = isequal - - end function psb_c_sgecmpmat_val - - function psb_c_sgeaddconst(xh,bh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - 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 :: bh - - 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 - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_geaddconst(xp,bh,zp,descp,info) - - res = info - - end function psb_c_sgeaddconst - - function psb_c_smask(ch,xh,mh,t,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_svector) :: ch,xh,mh - type(psb_c_descriptor) :: cdh - logical(c_bool) :: t - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: cp,xp,mp - integer(psb_c_ipk_) :: info - logical :: fp - - res = -1 - - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(ch%item)) then - call c_f_pointer(ch%item,cp) - else - return - end if - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,mp) - else - return - end if - - call psb_mask(cp,xp,mp,fp,descp,info) - - t = fp - res = info - - end function psb_c_smask - - function psb_c_sminquotient(xh,yh,cdh) bind(c) result(res) - implicit none - real(psb_spk_) :: res - - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - res = psb_minquotient(xp,yp,descp,info) - - - end function psb_c_sminquotient - - function psb_c_sgenrm2(xh,cdh) bind(c) result(res) - implicit none - real(c_float) :: res - - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - res = psb_genrm2(xp,descp,info) - - end function psb_c_sgenrm2 - - function psb_c_sgenrmi(xh,cdh) bind(c) result(res) - implicit none - real(c_float) :: res - - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - type(psb_s_vect_type) :: yp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - call psb_geall(yp,descp,info) - call psb_geabs(xp,yp,descp,info) - res = psb_geasum(yp,descp,info) - call psb_gefree(yp,descp,info) - - end function psb_c_sgenrmi - - function psb_c_sgenrm2_weight(xh,wh,cdh) bind(c) result(res) - implicit none - real(c_float) :: res - - type(psb_c_svector) :: xh, wh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp, wp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - if (c_associated(wh%item)) then - call c_f_pointer(wh%item,wp) - else - return - end if - - res = psb_genrm2(xp,wp,descp,info) - - end function psb_c_sgenrm2_weight - - function psb_c_sgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) - implicit none - real(c_float) :: res - - type(psb_c_svector) :: xh, wh, idvh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp, wp, idvp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - if (c_associated(wh%item)) then - call c_f_pointer(wh%item,wp) - else - return - end if - if (c_associated(idvh%item)) then - call c_f_pointer(idvh%item,idvp) - else - return - end if - - res = psb_genrm2(xp,wp,idvp,descp,info) - - end function psb_c_sgenrm2_weightmask - - function psb_c_sgeamax(xh,cdh) bind(c) result(res) - implicit none - real(c_float) :: res - - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - - res = psb_geamax(xp,descp,info) - - end function psb_c_sgeamax - - function psb_c_sgemin(xh,cdh) bind(c) result(res) - implicit none - real(c_float) :: res - - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - - res = psb_gemin(xp,descp,info) - - end function psb_c_sgemin - - function psb_c_sgeasum(xh,cdh) bind(c) result(res) - implicit none - real(c_float) :: res - - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - res = psb_geasum(xp,descp,info) - - end function psb_c_sgeasum - - - function psb_c_sspnrmi(ah,cdh) bind(c) result(res) - implicit none - real(c_float) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - - res = psb_spnrmi(ap,descp,info) - - end function psb_c_sspnrmi - - function psb_c_sgedot(xh,yh,cdh) bind(c) result(res) - implicit none - real(c_float) :: res - - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - res = psb_gedot(xp,yp,descp,info) - - end function psb_c_sgedot - - - function psb_c_sspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - real(c_float), value :: alpha, beta - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - call psb_spmm(alpha,ap,xp,beta,yp,descp,info) - - res = info - - end function psb_c_sspmm - - - function psb_c_sspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - real(c_float), value :: alpha, beta - character(c_char) :: trans - logical(c_bool), value :: doswap - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - type(psb_sspmat_type), pointer :: ap - character :: ftrans - logical :: fdoswap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - fdoswap = doswap - ftrans = trans - call psb_spmm(alpha,ap,xp,beta,yp,descp,info,trans=ftrans,doswap=fdoswap) - - res = info - - end function psb_c_sspmm_opt - - - function psb_c_sspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_svector) :: xh,yh - type(psb_c_descriptor) :: cdh - real(c_float), value :: alpha, beta - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp,yp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - call psb_spsm(alpha,ap,xp,beta,yp,descp,info) - - res = info - - end function psb_c_sspsm - - function psb_c_snnz(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - - 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 - - res = psb_nnz(ap,descp,info) - - end function psb_c_snnz - - function psb_c_sis_matupd(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_upd() - end function - - function psb_c_sis_matasb(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_asb() - end function - - function psb_c_sis_matbld(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_bld() - end function - - function psb_c_sset_matupd(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - - 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 - - call ap%set_upd() - - res = psb_success_ - end function - - function psb_c_sset_matasb(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - - 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 - - call ap%set_asb() - - res = psb_success_ - - end function - - function psb_c_sset_matbld(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - - 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 - - call ap%set_bld() - - res = psb_success_ - end function - - function psb_c_scopy_mat(ah,bh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_sspmat) :: ah,bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call ap%clone(bp,info) - - res = info - end function - - function psb_c_sspscal(alpha,ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - real(c_float), value :: alpha - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - - call ap%scal(alpha,info) - - res = info - - end function psb_c_sspscal - - function psb_c_sspscalpid(alpha,ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - real(c_float), value :: alpha - type(psb_c_sspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - - call ap%scalpid(alpha,info) - - res = info - - end function psb_c_sspscalpid - - function psb_c_sspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - real(c_float), value :: alpha - type(psb_c_sspmat) :: ah - real(c_float), value :: beta - type(psb_c_sspmat) :: bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call ap%spaxpby(alpha,beta,bp,info) - - res = info - end function psb_c_sspaxpby + interface + module function psb_c_sgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + real(c_float), value :: alpha,beta + end function psb_c_sgeaxpby + end interface + + interface + module function psb_c_sgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + real(c_float), value :: alpha,beta + end function psb_c_sgeaxpbyz + end interface + + interface + module function psb_c_sgemlt(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_sgemlt + end interface + + interface + module function psb_c_sgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + real(psb_spk_), intent(in), value :: alpha,beta + end function psb_c_sgemlt2 + end interface + + interface + module function psb_c_sgediv(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_sgediv + end interface + + interface + module function psb_c_sgediv2(xh,yh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + end function psb_c_sgediv2 + end interface + + interface + module function psb_c_sgediv_check(xh,yh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_sgediv_check + end interface + + interface + module function psb_c_sgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_sgediv2_check + end interface + + interface + module function psb_c_sgeinv(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_sgeinv + end interface + + interface + module function psb_c_sgeinv_check(xh,yh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_sgeinv_check + end interface + + interface + module function psb_c_sgeabs(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_sgeabs + end interface + + interface + module function psb_c_sgecmp(xh,ch,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,zh + type(psb_c_descriptor) :: cdh + real(c_float), value :: ch + end function psb_c_sgecmp + end interface + + interface + module function psb_c_sgecmpmat(ah,bh,tol,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_sspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + real(c_float), value :: tol + end function psb_c_sgecmpmat + end interface + + interface + module function psb_c_sgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + real(c_float), value :: val + real(c_float), value :: tol + end function psb_c_sgecmpmat_val + end interface + + interface + module function psb_c_sgeaddconst(xh,bh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh,zh + type(psb_c_descriptor) :: cdh + real(c_float), value :: bh + end function psb_c_sgeaddconst + end interface + + interface + module function psb_c_smask(ch,xh,mh,t,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: ch,xh,mh + type(psb_c_descriptor) :: cdh + logical(c_bool) :: t + end function psb_c_smask + end interface + + interface + module function psb_c_sminquotient(xh,yh,cdh) bind(c) result(res) + real(psb_spk_) :: res + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_sminquotient + end interface + + interface + module function psb_c_sgenrm2(xh,cdh) bind(c) result(res) + real(c_float) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sgenrm2 + end interface + + interface + module function psb_c_sgenrmi(xh,cdh) bind(c) result(res) + real(c_float) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sgenrmi + end interface + + interface + module function psb_c_sgenrm2_weight(xh,wh,cdh) bind(c) result(res) + real(c_float) :: res + type(psb_c_svector) :: xh, wh + type(psb_c_descriptor) :: cdh + end function psb_c_sgenrm2_weight + end interface + + interface + module function psb_c_sgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) + real(c_float) :: res + type(psb_c_svector) :: xh, wh, idvh + type(psb_c_descriptor) :: cdh + end function psb_c_sgenrm2_weightmask + end interface + + interface + module function psb_c_sgeamax(xh,cdh) bind(c) result(res) + real(c_float) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sgeamax + end interface + + interface + module function psb_c_sgemin(xh,cdh) bind(c) result(res) + real(c_float) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sgemin + end interface + + interface + module function psb_c_sgeasum(xh,cdh) bind(c) result(res) + real(c_float) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sgeasum + end interface + + interface + module function psb_c_sspnrmi(ah,cdh) bind(c) result(res) + real(c_float) :: res + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_sspnrmi + end interface + + interface + module function psb_c_sgedot(xh,yh,cdh) bind(c) result(res) + real(c_float) :: res + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_sgedot + end interface + + interface + module function psb_c_sspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: ah + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + real(c_float), value :: alpha, beta + end function psb_c_sspmm + end interface + + interface + module function psb_c_sspmm_opt(alpha,ah,xh,beta,yh,& + & cdh,trans,doswap) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: ah + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + real(c_float), value :: alpha, beta + character(c_char) :: trans + logical(c_bool), value :: doswap + end function psb_c_sspmm_opt + end interface + + interface + module function psb_c_sspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: ah + type(psb_c_svector) :: xh,yh + type(psb_c_descriptor) :: cdh + real(c_float), value :: alpha, beta + type(psb_desc_type), pointer :: descp + end function psb_c_sspsm + end interface + + interface + module function psb_c_snnz(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_snnz + end interface + + interface + module function psb_c_sis_matupd(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_sis_matasb(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_sis_matbld(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_sset_matupd(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_sset_matasb(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_sset_matbld(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_scopy_mat(ah,bh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_sspscal(alpha,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + real(c_float), value :: alpha + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_sspscal + end interface + + interface + module function psb_c_sspscalpid(alpha,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + real(c_float), value :: alpha + type(psb_c_sspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_sspscalpid + end interface + + interface + module function psb_c_sspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + real(c_float), value :: alpha + type(psb_c_sspmat) :: ah + real(c_float), value :: beta + type(psb_c_sspmat) :: bh + type(psb_c_descriptor) :: cdh + end function psb_c_sspaxpby + end interface end module psb_s_psblas_cbind_mod diff --git a/cbind/base/psb_s_serial_cbind_mod.F90 b/cbind/base/psb_s_serial_cbind_mod.F90 index 9fa7d308..e4ce9f72 100644 --- a/cbind/base/psb_s_serial_cbind_mod.F90 +++ b/cbind/base/psb_s_serial_cbind_mod.F90 @@ -4,293 +4,110 @@ module psb_s_serial_cbind_mod use psb_objhandle_mod use psb_base_tools_cbind_mod -contains - - function psb_c_svect_get_nrows(xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_svector) :: xh - - type(psb_s_vect_type), pointer :: vp - integer(psb_c_ipk_) :: info - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - res = vp%get_nrows() - end if - - end function psb_c_svect_get_nrows - - function psb_c_svect_f_get_cpy(v,xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - real(c_float) :: v(*) - type(psb_c_svector) :: xh - - type(psb_s_vect_type), pointer :: vp - real(psb_spk_), allocatable :: fv(:) - integer(psb_c_ipk_) :: info, sz - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - fv = vp%get_vect() - sz = size(fv) - v(1:sz) = fv(1:sz) - end if - - end function psb_c_svect_f_get_cpy - - - function psb_c_svect_zero(xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_svector) :: xh - - type(psb_s_vect_type), pointer :: vp - integer(psb_c_ipk_) :: info - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - call vp%zero() - end if - - end function psb_c_svect_zero - - function psb_c_svect_f_get_pnt(xh) bind(c) result(res) - implicit none - - type(c_ptr) :: res - type(psb_c_svector) :: xh - - type(psb_s_vect_type), pointer :: vp - - res = c_null_ptr - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - if(vp%is_dev()) call vp%sync() - res = c_loc(vp%v%v) - end if - - end function psb_c_svect_f_get_pnt - - - function psb_c_smat_get_nrows(mh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_sspmat) :: mh - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - res = ap%get_nrows() - - end function psb_c_smat_get_nrows - - - function psb_c_smat_get_ncols(mh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_sspmat) :: mh - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - res = ap%get_ncols() - - end function psb_c_smat_get_ncols - - - function psb_c_smat_name_print(mh,name) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - character(c_char) :: name(*) - type(psb_c_sspmat) :: mh - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - character(1024) :: fname - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - call psb_stringc2f(name,fname) - - call ap%print(fname,head='PSBLAS Cbinding Interface') - - end function psb_c_smat_name_print - - function psb_c_svect_set_scal(x,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 - real(c_float), value :: val - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val) - - info = 0 - - end function psb_c_svect_set_scal - - function psb_c_svect_set_scal_bound(x,val,ifirst,ilast) 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 :: ifirst, ilast - real(c_float) :: val - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val,first=ifirst,last=ilast) - - info = 0 - - end function psb_c_svect_set_scal_bound - - function psb_c_svect_set_vect(x,val,n) 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 :: n - real(c_float) :: val(*) - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val(1:n)) - - info = 0 - - 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 + interface + module function psb_c_svect_get_nrows(xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + + type(psb_s_vect_type), pointer :: vp + integer(psb_c_ipk_) :: info + end function psb_c_svect_get_nrows + end interface + + interface + module function psb_c_svect_f_get_cpy(v,xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + real(c_float) :: v(*) + type(psb_c_svector) :: xh + end function psb_c_svect_f_get_cpy + end interface + + + interface + module function psb_c_svect_zero(xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + end function psb_c_svect_zero + end interface + + interface + module function psb_c_svect_f_get_pnt(xh) bind(c) result(res) + type(c_ptr) :: res + type(psb_c_svector) :: xh + end function psb_c_svect_f_get_pnt + end interface + + interface + module function psb_c_smat_get_nrows(mh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: mh + end function psb_c_smat_get_nrows + end interface + + interface + module function psb_c_smat_get_ncols(mh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: mh + end function psb_c_smat_get_ncols + end interface + + interface + module function psb_c_smat_name_print(mh,name) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: mh + character(c_char) :: name(*) + end function psb_c_smat_name_print + end interface + + interface + module function psb_c_svect_set_scal(x,val) bind(c) result(info) + type(psb_c_svector) :: x + integer(psb_c_ipk_) :: info + real(c_float), value :: val + end function psb_c_svect_set_scal + end interface + + interface + module function psb_c_svect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + type(psb_c_svector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + real(c_float) :: val + end function psb_c_svect_set_scal_bound + end interface + + interface + module function psb_c_svect_set_vect(x,val,n) bind(c) result(info) + type(psb_c_svector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: n + real(c_float) :: val(*) + end function psb_c_svect_set_vect + end interface + + interface + module function psb_c_svect_set_entry(x,index,val) bind(c) result(info) + type(psb_c_svector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + real(c_float), value :: val + end function psb_c_svect_set_entry + end interface - 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 - - integer(psb_c_ipk_) :: info - type(psb_c_svector) :: xh,yh - - type(psb_s_vect_type), pointer :: xp,yp - - info = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - call xp%clone(yp,info) - - end function psb_c_svect_clone + interface + module function psb_c_svect_get_entry(x,index) bind(c) result(res) + type(psb_c_svector) :: x + integer(psb_c_ipk_), value :: index + real(c_float) :: res + end function psb_c_svect_get_entry + end interface + + interface + module function psb_c_svect_clone(xh,yh) bind(c) result(info) + integer(psb_c_ipk_) :: info + type(psb_c_svector) :: xh,yh + end function psb_c_svect_clone + end interface end module psb_s_serial_cbind_mod diff --git a/cbind/base/psb_s_tools_cbind_mod.F90 b/cbind/base/psb_s_tools_cbind_mod.F90 index 54951b21..9fb94bcf 100644 --- a/cbind/base/psb_s_tools_cbind_mod.F90 +++ b/cbind/base/psb_s_tools_cbind_mod.F90 @@ -8,614 +8,145 @@ module psb_s_tools_cbind_mod use psb_cuda_mod #endif -contains - ! Should define geall_opt with DUPL argument - function psb_c_sgeall(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_sgeall - - function psb_c_sgeall_remote(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info,bldmode=psb_matbld_remote_,dupl=psb_dupl_add_) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_sgeall_remote - - function psb_c_sgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: dupl - integer(psb_c_ipk_), value :: bldmode - - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info,bldmode=bldmode,dupl=dupl) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_sgeall_remote_options - - function psb_c_sgeasb(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_geasb(xp,descp,info) - res = min(0,info) - - return - end function psb_c_sgeasb - - function psb_c_sgeasb_options(xh,cdh,dupl) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: dupl - - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_geasb(xp,descp,info,dupl=dupl) - res = min(0,info) - - return - end function psb_c_sgeasb_options - - function psb_c_sgeasb_options_format(xh,cdh,dupl,format) bind(c) result(res) - ! Takes into account format argument as a c string, and uses it to call the appropriate psb_geasb - ! with mold argument - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - character(kind=c_char), dimension(*) :: format - integer(psb_c_ipk_), value :: dupl - - ! Local variables - character(len=6) :: fformat - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - ! mold variables -#ifdef PSB_HAVE_CUDA - type(psb_s_vect_cuda), target :: vgpu -#endif - type(psb_s_base_vect_type), target :: vect - class(psb_s_base_vect_type), pointer :: vmold - - ! Select mold based on format - call psb_stringc2f(format,fformat) - - select case (psb_toupper(fformat)) -#ifdef PSB_HAVE_CUDA - case('GPU','DEVICE') - vmold => vgpu -#endif - case('CPU','HOST') - vmold => vect - case default - write(psb_out_unit,*) 'psb_c_sgeasb_options_format: Unknown format ',fformat - vmold => vect - end select - 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 - - call psb_geasb(xp,descp,info,dupl=dupl,mold=vmold) - res = min(0,info) - - return - end function psb_c_sgeasb_options_format - - - function psb_c_sgefree(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_gefree(xp,descp,info) - res = min(0,info) - deallocate(xp,stat=info) - res = min(0,info) - xh%item = c_null_ptr - - return - end function psb_c_sgefree - - - function psb_c_sgeins(nz,irw,val,xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*) - real(c_float) :: val(*) - type(psb_c_svector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_s_vect_type), pointer :: xp - integer(psb_c_ipk_) :: ixb, info - - res = -1 - info = 0 - 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 - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_geins(nz,irw(1:nz),val(1:nz),& - & xp,descp,info) - else - call psb_geins(nz,(irw(1:nz)+(1-ixb)),val(1:nz),& - & xp,descp,info) - end if - - res = min(0,info) - - return - end function psb_c_sgeins - - function psb_c_sspall(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_sspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - return - end if - allocate(ap) - call psb_spall(ap,descp,info) - mh%item = c_loc(ap) - res = min(0,info) - - return - end function psb_c_sspall - - - function psb_c_sspall_remote(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_sspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - return - end if - allocate(ap) - call psb_spall(ap,descp,info,bldmode=psb_matbld_remote_,dupl=psb_dupl_add_) - mh%item = c_loc(ap) - res = min(0,info) - - return - end function psb_c_sspall_remote - - function psb_c_sspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_sspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - call psb_spasb(ap,descp,info) - res = min(0,info) - return - end function psb_c_sspasb - - function psb_c_sspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_sspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - call psb_spfree(ap,descp,info) - res = min(0,info) - deallocate(ap,stat=info) - mh%item=c_null_ptr - return - end function psb_c_sspfree - - - - - function psb_c_sspasb_opt(mh,cdh,afmt,upd,dupl) bind(c) result(res) - -#if 0 -#ifdef PSB_HAVE_LIBRSB - use psb_s_rsb_mat_mod -#endif -#endif -#if defined(PSB_HAVE_CUDA) - use psb_cuda_mod -#endif - use psb_ext_mod - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_sspmat) :: mh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: upd,dupl - character(c_char) :: afmt(*) - integer(psb_c_ipk_) :: info,n - character(len=5) :: fafmt - integer(psb_ipk_), parameter :: hksz = 32 - ! mold variables -#if 0 -#ifdef PSB_HAVE_LIBRSB - type(psb_s_rsb_sparse_mat) :: arsb -#endif -#endif - type(psb_s_ell_sparse_mat), target :: aell - type(psb_s_csr_sparse_mat), target :: acsr - type(psb_s_csc_sparse_mat), target :: acsc - type(psb_s_coo_sparse_mat), target :: acoo - type(psb_s_hll_sparse_mat), target :: ahll - type(psb_s_hdia_sparse_mat), target :: ahdia - type(psb_s_dns_sparse_mat), target :: adns -#if defined(PSB_HAVE_CUDA) - type(psb_s_cuda_hlg_sparse_mat), target :: ahlg - type(psb_s_cuda_hdiag_sparse_mat), target :: ahdiag - type(psb_s_cuda_csrg_sparse_mat), target :: acsrg - type(psb_s_cuda_elg_sparse_mat), target :: aelg -#endif - class(psb_s_base_sparse_mat), pointer :: amold - !Local variables - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - call psb_stringc2f(afmt,fafmt) - - ! Set the mold variable based on afmt - select case (psb_toupper(fafmt)) -#if defined(PSB_HAVE_CUDA) - case('ELG') - amold => aelg - case('HLG') - call psi_set_hksz(hksz) - amold => ahlg - case('HDIAG') - amold => ahdiag - case('CSRG') - amold => acsrg - case('ELL') - amold => aell - case('HLL') - call psi_set_hksz(hksz) - amold => ahll - case('HDIA') - amold => ahdia - case('CSR') - amold => acsr - case('CSC') - amold => acsc - case('DNS') - amold => adns - case default - write(*,*) 'Unknown format defaulting to HLG' - amold => ahlg -#else - case('ELL') - amold => aell - case('HLL') - call psi_set_hksz(hksz) - amold => ahll - case('HDIA') - amold => ahdia - case('CSR') - amold => acsr - case('CSC') - amold => acsc - case('DNS') - amold => adns - case default - write(*,*) 'Unknown format defaulting to CSR' - amold => acsr -#endif - end select - - select case(fafmt) -#if 0 -#ifdef PSB_HAVE_LIBRSB - case('RSB') - call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& - & upd=upd,mold=arsb) -#endif -#endif - case('ELL','HLL','CSR','DNS','CSC') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) - case('HDIA') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) -#if defined(PSB_HAVE_CUDA) - case('ELG','HLG','CSRG') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) - case('HDIAG') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) -#endif - case default - write(psb_out_unit,*) 'psb_c_sspasb_opt: Unknown format ',fafmt - call psb_spasb(ap,descp,info,afmt=fafmt,upd=upd,dupl=dupl) - end select - - res = min(0,info) - - return - end function psb_c_sspasb_opt - - - function psb_c_sspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) - real(c_float) :: val(*) - type(psb_c_sspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - integer(psb_c_ipk_) :: ixb,info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) - else - call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) - end if - res = min(0,info) - return - end function psb_c_sspins - - - function psb_c_ssprn(mh,cdh,clear) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - logical(c_bool), value :: clear - type(psb_c_sspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_sspmat_type), pointer :: ap - 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(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - fclear = clear - call psb_sprn(ap,descp,info,clear=fclear) - res = min(0,info) - - return - end function psb_c_ssprn + interface + module function psb_c_sgeall(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sgeall + end interface + + interface + module function psb_c_sgeall_remote(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + + end function psb_c_sgeall_remote + end interface + + interface + module function psb_c_sgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: dupl + integer(psb_c_ipk_), value :: bldmode + end function psb_c_sgeall_remote_options + end interface + + interface + module function psb_c_sgeasb(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sgeasb + end interface + + interface + module function psb_c_sgeasb_options(xh,cdh,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: dupl + end function psb_c_sgeasb_options + end interface + + interface + module function psb_c_sgeasb_options_format(xh,cdh,dupl,format) bind(c) result(res) + ! Takes into account format argument as a c string, and uses it to call the appropriate psb_geasb + ! with mold argument + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + character(kind=c_char), dimension(*) :: format + integer(psb_c_ipk_), value :: dupl + end function psb_c_sgeasb_options_format + end interface + + interface + module function psb_c_sgefree(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sgefree + end interface + + interface + module function psb_c_sgeins(nz,irw,val,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: nz + integer(psb_c_lpk_) :: irw(*) + real(c_float) :: val(*) + type(psb_c_svector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_sgeins + end interface + + interface + module function psb_c_sspall(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_sspall + end interface + + interface + module function psb_c_sspall_remote(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_sspall_remote + end interface + + interface + module function psb_c_sspasb(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_sspasb + end interface + + interface + module function psb_c_sspfree(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_sspfree + end interface + + interface + module function psb_c_sspasb_opt(mh,cdh,afmt,upd,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_sspmat) :: mh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: upd,dupl + character(c_char) :: afmt(*) + end function psb_c_sspasb_opt + end interface + + interface + module function psb_c_sspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: nz + integer(psb_c_lpk_) :: irw(*), icl(*) + real(c_float) :: val(*) + type(psb_c_sspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_sspins + end interface + + interface + module function psb_c_ssprn(mh,cdh,clear) bind(c) result(res) + integer(psb_c_ipk_) :: res + logical(c_bool), value :: clear + type(psb_c_sspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_ssprn + end interface !!$ -!!$ function psb_c_sspprint(mh) bind(c) result(res) +!!$ module function psb_c_sspprint(mh) bind(c) result(res) !!$ !!$ implicit none !!$ integer(psb_c_ipk_) :: res @@ -634,109 +165,32 @@ contains !!$ return !!$ end function psb_c_sspprint - function psb_c_sgetelem(xh,index,cdh) bind(c) result(res) - implicit none - - type(psb_c_svector) :: xh - integer(psb_c_lpk_), value :: index - type(psb_c_descriptor) :: cdh - real(c_float) :: res - - type(psb_s_vect_type), pointer :: xp - 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(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - res = psb_getelem(xp,index,descp,info) - else - res = psb_getelem(xp,index+(1-ixb),descp,info) - end if - - return - - end function psb_c_sgetelem - - function psb_c_ssetelem(index,val,xh,cdh) bind(c) result(res) - implicit none - - type(psb_c_svector) :: xh - integer(psb_c_lpk_), value :: index - type(psb_c_descriptor) :: cdh - real(c_float), value :: val - integer(psb_c_ipk_) :: res - - type(psb_s_vect_type), pointer :: xp - 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(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_setelem(index,val,xp,descp,info) - else - call psb_setelem(index+(1-ixb),val,xp,descp,info) - end if - res=info - return - - end function psb_c_ssetelem - - 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 + interface + module function psb_c_sgetelem(xh,index,cdh) bind(c) result(res) + type(psb_c_svector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + real(c_float) :: res + end function psb_c_sgetelem + end interface + + interface + module function psb_c_ssetelem(index,val,xh,cdh) bind(c) result(res) + type(psb_c_svector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + real(c_float), value :: val + integer(psb_c_ipk_) :: res + end function psb_c_ssetelem + end interface + + interface + module function psb_c_smatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) + type(psb_c_sspmat) :: ah + integer(psb_c_lpk_), value :: rowindex, colindex + type(psb_c_descriptor) :: cdh + real(c_float) :: res + end function psb_c_smatgetelem + end interface end module psb_s_tools_cbind_mod diff --git a/cbind/base/psb_z_comm_cbind_mod.f90 b/cbind/base/psb_z_comm_cbind_mod.f90 index 4e436951..2a78857d 100644 --- a/cbind/base/psb_z_comm_cbind_mod.f90 +++ b/cbind/base/psb_z_comm_cbind_mod.f90 @@ -3,236 +3,67 @@ module psb_z_comm_cbind_mod use psb_base_mod use psb_objhandle_mod -contains - - function psb_c_zovrl(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_ovrl(xp,descp,info) - - res = info - - end function psb_c_zovrl - - function psb_c_zovrl_opt(xh,cdh,update,mode) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: update, mode - - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_ovrl(xp,descp,info,update=update,mode=mode) - - res = info - - end function psb_c_zovrl_opt - - - function psb_c_zhalo(xh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - - 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 - - call psb_halo(xp,descp,info) - - res = info - - end function psb_c_zhalo - - function psb_c_zhalo_opt(xh,cdh,tran,data,mode) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: data, mode - character(c_char) :: tran - - - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - character :: ftran - integer(psb_c_ipk_) :: info - - - 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 - - ftran = tran - call psb_halo(xp,descp,info,data=data,mode=mode,tran=ftran) - - res = info - - end function psb_c_zhalo_opt - - - function psb_c_zvscatter(ng,gx,xh,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - integer(psb_c_lpk_), value :: ng - complex(c_double_complex), target :: gx(*) - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: vp - complex(psb_dpk_), pointer :: pgx(:) - integer(psb_c_ipk_) :: info, sz - - 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,vp) - else - return - end if - - pgx => gx(1:ng) - - call psb_scatter(pgx,vp,descp,info) - res = info - - end function psb_c_zvscatter - - function psb_c_zvgather_f(v,xh,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - complex(c_double_complex), target :: v(*) - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: vp - complex(psb_dpk_), allocatable :: fv(:) - integer(psb_c_ipk_) :: info, sz - - 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,vp) - else - return - end if - - call psb_gather(fv,vp,descp,info) - res = info - if (res /=0) return - sz = size(fv) - v(1:sz) = fv(1:sz) - end function psb_c_zvgather_f - - function psb_c_zspgather_f(gah,ah,cdh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_zspmat) :: ah, gah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap, gap - integer(psb_c_ipk_) :: info, sz - - 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 - if (c_associated(gah%item)) then - call c_f_pointer(gah%item,gap) - else - return - end if - call psb_gather(gap,ap,descp,info) - res = info - end function psb_c_zspgather_f - + interface + module function psb_c_zovrl(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zovrl + end interface + + interface + module function psb_c_zovrl_opt(xh,cdh,update,mode) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: update, mode + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zovrl_opt + end interface + + + interface + module function psb_c_zhalo(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zhalo + end interface + + interface + module function psb_c_zhalo_opt(xh,cdh,tran,data,mode) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: data, mode + character(c_char) :: tran + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zhalo_opt + end interface + + interface + module function psb_c_zvscatter(ng,gx,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_lpk_), value :: ng + complex(c_double_complex), target :: gx(*) + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zvscatter + end interface + + interface + module function psb_c_zvgather_f(v,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + complex(c_double_complex), target :: v(*) + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zvgather_f + end interface + + interface + module function psb_c_zspgather_f(gah,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: ah, gah + type(psb_c_descriptor) :: cdh + end function psb_c_zspgather_f + end interface + end module psb_z_comm_cbind_mod diff --git a/cbind/base/psb_z_psblas_cbind_mod.f90 b/cbind/base/psb_z_psblas_cbind_mod.f90 index 511b390f..03a1b2b8 100644 --- a/cbind/base/psb_z_psblas_cbind_mod.f90 +++ b/cbind/base/psb_z_psblas_cbind_mod.f90 @@ -3,1265 +3,329 @@ module psb_z_psblas_cbind_mod use psb_base_mod use psb_objhandle_mod -contains - function psb_c_zgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - complex(c_double_complex), value :: alpha,beta - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geaxpby(alpha,xp,beta,yp,descp,info) - - res = info - - end function psb_c_zgeaxpby - - function psb_c_zgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - complex(c_double_complex), value :: alpha,beta - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_geaxpby(alpha,xp,beta,yp,zp,descp,info) - - res = info - - end function psb_c_zgeaxpbyz - - function psb_c_zgemlt(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_gemlt(xp,yp,descp,info) - - res = info - - end function psb_c_zgemlt - - function psb_c_zgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh, zh - type(psb_c_descriptor) :: cdh - - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - complex(psb_dpk_), intent(in), value :: alpha,beta - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gemlt(alpha,xp,yp,beta,zp,descp,info) - - res = info - - end function psb_c_zgemlt2 - - function psb_c_zgediv(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_gediv(xp,yp,descp,info) - - res = info - - end function psb_c_zgediv - - function psb_c_zgediv2(xh,yh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gediv(xp,yp,zp,descp,info) - - res = info - - end function psb_c_zgediv2 - - function psb_c_zgediv_check(xh,yh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - fflag = flag - call psb_gediv(xp,yp,descp,info,fflag) - - res = info - - end function psb_c_zgediv_check - - function psb_c_zgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh,zh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp,zp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - fflag = flag - call psb_gediv(xp,yp,zp,descp,info,fflag) - - res = info - - end function psb_c_zgediv2_check - - function psb_c_zgeinv(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geinv(xp,yp,descp,info) - - res = info - - end function psb_c_zgeinv - - function psb_c_zgeinv_check(xh,yh,cdh, flag) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - logical(c_bool), value :: flag - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - logical :: fflag - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - fflag = flag - call psb_geinv(xp,yp,descp,info,fflag) - - res = info - - end function psb_c_zgeinv_check - - function psb_c_zgeabs(xh,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - - call psb_geabs(xp,yp,descp,info) - - res = info - - end function psb_c_zgeabs - - function psb_c_zgecmp(xh,ch,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - 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 - - 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 - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_gecmp(xp,ch,zp,descp,info) - - res = info - - end function psb_c_zgecmp - - function psb_c_zgecmpmat(ah,bh,tol,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_zspmat) :: ah,bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - real(c_double_complex), value :: tol - logical :: isequal - - res = .false. - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call psb_gecmp(ap,bp,tol,descp,isequal,info) - - res = isequal - - end function psb_c_zgecmpmat - - function psb_c_zgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - complex(c_double_complex), value :: val - real(c_double_complex), value :: tol - logical :: isequal - - res = .false. - - 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 - - call psb_gecmp(ap,val,tol,descp,isequal,info) - - res = isequal - - end function psb_c_zgecmpmat_val - - function psb_c_zgeaddconst(xh,bh,zh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - 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 :: bh - - 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 - if (c_associated(zh%item)) then - call c_f_pointer(zh%item,zp) - else - return - end if - - call psb_geaddconst(xp,bh,zp,descp,info) - - res = info - - end function psb_c_zgeaddconst - - - function psb_c_zgenrm2(xh,cdh) bind(c) result(res) - implicit none - real(c_double_complex) :: res - - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - res = psb_genrm2(xp,descp,info) - - end function psb_c_zgenrm2 - - function psb_c_zgenrmi(xh,cdh) bind(c) result(res) - implicit none - real(c_double_complex) :: res - - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - type(psb_z_vect_type) :: yp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - call psb_geall(yp,descp,info) - call psb_geabs(xp,yp,descp,info) - res = psb_geasum(yp,descp,info) - call psb_gefree(yp,descp,info) - - end function psb_c_zgenrmi - - function psb_c_zgenrm2_weight(xh,wh,cdh) bind(c) result(res) - implicit none - real(c_double_complex) :: res - - type(psb_c_zvector) :: xh, wh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp, wp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - if (c_associated(wh%item)) then - call c_f_pointer(wh%item,wp) - else - return - end if - - res = psb_genrm2(xp,wp,descp,info) - - end function psb_c_zgenrm2_weight - - function psb_c_zgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) - implicit none - real(c_double_complex) :: res - - type(psb_c_zvector) :: xh, wh, idvh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp, wp, idvp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - if (c_associated(wh%item)) then - call c_f_pointer(wh%item,wp) - else - return - end if - if (c_associated(idvh%item)) then - call c_f_pointer(idvh%item,idvp) - else - return - end if - - res = psb_genrm2(xp,wp,idvp,descp,info) - - end function psb_c_zgenrm2_weightmask - - function psb_c_zgeamax(xh,cdh) bind(c) result(res) - implicit none - real(c_double_complex) :: res - - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - - res = psb_geamax(xp,descp,info) - - end function psb_c_zgeamax - - - function psb_c_zgeasum(xh,cdh) bind(c) result(res) - implicit none - real(c_double_complex) :: res - - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - res = -1.0 - - 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 - - res = psb_geasum(xp,descp,info) - - end function psb_c_zgeasum - - - function psb_c_zspnrmi(ah,cdh) bind(c) result(res) - implicit none - real(c_double_complex) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - - res = psb_spnrmi(ap,descp,info) - - end function psb_c_zspnrmi - - function psb_c_zgedot(xh,yh,cdh) bind(c) result(res) - implicit none - complex(c_double_complex) :: res - - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - integer(psb_c_ipk_) :: info - - res = -1.0 - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - res = psb_gedot(xp,yp,descp,info) - - end function psb_c_zgedot - - - function psb_c_zspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - complex(c_double_complex), value :: alpha, beta - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - call psb_spmm(alpha,ap,xp,beta,yp,descp,info) - - res = info - - end function psb_c_zspmm - - - function psb_c_zspmm_opt(alpha,ah,xh,beta,yh,cdh,trans,doswap) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - complex(c_double_complex), value :: alpha, beta - character(c_char) :: trans - logical(c_bool), value :: doswap - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - type(psb_zspmat_type), pointer :: ap - character :: ftrans - logical :: fdoswap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - fdoswap = doswap - ftrans = trans - call psb_spmm(alpha,ap,xp,beta,yp,descp,info,trans=ftrans,doswap=fdoswap) - - res = info - - end function psb_c_zspmm_opt - - - function psb_c_zspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_zvector) :: xh,yh - type(psb_c_descriptor) :: cdh - complex(c_double_complex), value :: alpha, beta - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp,yp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - if (c_associated(ah%item)) then - call c_f_pointer(ah%item,ap) - else - return - end if - - call psb_spsm(alpha,ap,xp,beta,yp,descp,info) - - res = info - - end function psb_c_zspsm - - function psb_c_znnz(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - - 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 - - res = psb_nnz(ap,descp,info) - - end function psb_c_znnz - - function psb_c_zis_matupd(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_upd() - end function - - function psb_c_zis_matasb(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_asb() - end function - - function psb_c_zis_matbld(ah,cdh) bind(c) result(res) - implicit none - logical(c_bool) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = .false. - - 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 - - res = ap%is_bld() - end function - - function psb_c_zset_matupd(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - - 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 - - call ap%set_upd() - - res = psb_success_ - end function - - function psb_c_zset_matasb(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - - 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 - - call ap%set_asb() - - res = psb_success_ - - end function - - function psb_c_zset_matbld(ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - - 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 - - call ap%set_bld() - - res = psb_success_ - end function - - function psb_c_zcopy_mat(ah,bh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zspmat) :: ah,bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call ap%clone(bp,info) - - res = info - end function - - function psb_c_zspscal(alpha,ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - complex(c_double_complex), value :: alpha - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - - call ap%scal(alpha,info) - - res = info - - end function psb_c_zspscal - - function psb_c_zspscalpid(alpha,ah,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - complex(c_double_complex), value :: alpha - type(psb_c_zspmat) :: ah - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - 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 - - call ap%scalpid(alpha,info) - - res = info - - end function psb_c_zspscalpid - - function psb_c_zspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) - implicit none - integer(psb_c_ipk_) :: res - - complex(c_double_complex), value :: alpha - type(psb_c_zspmat) :: ah - complex(c_double_complex), value :: beta - type(psb_c_zspmat) :: bh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap,bp - integer(psb_c_ipk_) :: info - - 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 - if (c_associated(bh%item)) then - call c_f_pointer(bh%item,bp) - else - return - end if - - call ap%spaxpby(alpha,beta,bp,info) - - res = info - end function psb_c_zspaxpby + interface + module function psb_c_zgeaxpby(alpha,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + complex(c_double_complex), value :: alpha,beta + end function psb_c_zgeaxpby + end interface + + interface + module function psb_c_zgeaxpbyz(alpha,xh,beta,yh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + complex(c_double_complex), value :: alpha,beta + end function psb_c_zgeaxpbyz + end interface + + interface + module function psb_c_zgemlt(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_zgemlt + end interface + + interface + module function psb_c_zgemlt2(alpha,xh,yh,beta,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh, zh + type(psb_c_descriptor) :: cdh + complex(psb_dpk_), intent(in), value :: alpha,beta + end function psb_c_zgemlt2 + end interface + + interface + module function psb_c_zgediv(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_zgediv + end interface + + interface + module function psb_c_zgediv2(xh,yh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + end function psb_c_zgediv2 + end interface + + interface + module function psb_c_zgediv_check(xh,yh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_zgediv_check + end interface + + interface + module function psb_c_zgediv2_check(xh,yh,zh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh,zh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_zgediv2_check + end interface + + interface + module function psb_c_zgeinv(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_zgeinv + end interface + + interface + module function psb_c_zgeinv_check(xh,yh,cdh, flag) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + logical(c_bool), value :: flag + end function psb_c_zgeinv_check + end interface + + interface + module function psb_c_zgeabs(xh,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_zgeabs + end interface + + interface + module function psb_c_zgecmp(xh,ch,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,zh + type(psb_c_descriptor) :: cdh + real(c_double_complex), value :: ch + end function psb_c_zgecmp + end interface + + interface + module function psb_c_zgecmpmat(ah,bh,tol,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_zspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + real(c_double_complex), value :: tol + end function psb_c_zgecmpmat + end interface + + interface + module function psb_c_zgecmpmat_val(ah,val,tol,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + complex(c_double_complex), value :: val + real(c_double_complex), value :: tol + end function psb_c_zgecmpmat_val + end interface + + interface + module function psb_c_zgeaddconst(xh,bh,zh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh,zh + type(psb_c_descriptor) :: cdh + real(c_double_complex), value :: bh + end function psb_c_zgeaddconst + end interface + + + interface + module function psb_c_zgenrm2(xh,cdh) bind(c) result(res) + real(c_double_complex) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zgenrm2 + end interface + + interface + module function psb_c_zgenrmi(xh,cdh) bind(c) result(res) + real(c_double_complex) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zgenrmi + end interface + + interface + module function psb_c_zgenrm2_weight(xh,wh,cdh) bind(c) result(res) + real(c_double_complex) :: res + type(psb_c_zvector) :: xh, wh + type(psb_c_descriptor) :: cdh + end function psb_c_zgenrm2_weight + end interface + + interface + module function psb_c_zgenrm2_weightmask(xh,wh,idvh,cdh) bind(c) result(res) + real(c_double_complex) :: res + type(psb_c_zvector) :: xh, wh, idvh + type(psb_c_descriptor) :: cdh + end function psb_c_zgenrm2_weightmask + end interface + + interface + module function psb_c_zgeamax(xh,cdh) bind(c) result(res) + real(c_double_complex) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zgeamax + end interface + + + interface + module function psb_c_zgeasum(xh,cdh) bind(c) result(res) + real(c_double_complex) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zgeasum + end interface + + interface + module function psb_c_zspnrmi(ah,cdh) bind(c) result(res) + real(c_double_complex) :: res + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_zspnrmi + end interface + + interface + module function psb_c_zgedot(xh,yh,cdh) bind(c) result(res) + complex(c_double_complex) :: res + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + end function psb_c_zgedot + end interface + + interface + module function psb_c_zspmm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: ah + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + complex(c_double_complex), value :: alpha, beta + end function psb_c_zspmm + end interface + + interface + module function psb_c_zspmm_opt(alpha,ah,xh,beta,yh,& + & cdh,trans,doswap) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: ah + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + complex(c_double_complex), value :: alpha, beta + character(c_char) :: trans + logical(c_bool), value :: doswap + end function psb_c_zspmm_opt + end interface + + interface + module function psb_c_zspsm(alpha,ah,xh,beta,yh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: ah + type(psb_c_zvector) :: xh,yh + type(psb_c_descriptor) :: cdh + complex(c_double_complex), value :: alpha, beta + type(psb_desc_type), pointer :: descp + end function psb_c_zspsm + end interface + + interface + module function psb_c_znnz(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_znnz + end interface + + interface + module function psb_c_zis_matupd(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_zis_matasb(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_zis_matbld(ah,cdh) bind(c) result(res) + logical(c_bool) :: res + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_zset_matupd(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_zset_matasb(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_zset_matbld(ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_zcopy_mat(ah,bh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: ah,bh + type(psb_c_descriptor) :: cdh + end function + end interface + + interface + module function psb_c_zspscal(alpha,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + complex(c_double_complex), value :: alpha + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_zspscal + end interface + + interface + module function psb_c_zspscalpid(alpha,ah,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + complex(c_double_complex), value :: alpha + type(psb_c_zspmat) :: ah + type(psb_c_descriptor) :: cdh + end function psb_c_zspscalpid + end interface + + interface + module function psb_c_zspaxpby(alpha,ah,beta,bh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + complex(c_double_complex), value :: alpha + type(psb_c_zspmat) :: ah + complex(c_double_complex), value :: beta + type(psb_c_zspmat) :: bh + type(psb_c_descriptor) :: cdh + end function psb_c_zspaxpby + end interface end module psb_z_psblas_cbind_mod diff --git a/cbind/base/psb_z_serial_cbind_mod.F90 b/cbind/base/psb_z_serial_cbind_mod.F90 index d6fbd312..af4e4a24 100644 --- a/cbind/base/psb_z_serial_cbind_mod.F90 +++ b/cbind/base/psb_z_serial_cbind_mod.F90 @@ -4,293 +4,110 @@ module psb_z_serial_cbind_mod use psb_objhandle_mod use psb_base_tools_cbind_mod -contains - - function psb_c_zvect_get_nrows(xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_zvector) :: xh - - type(psb_z_vect_type), pointer :: vp - integer(psb_c_ipk_) :: info - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - res = vp%get_nrows() - end if - - end function psb_c_zvect_get_nrows - - function psb_c_zvect_f_get_cpy(v,xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - complex(c_double_complex) :: v(*) - type(psb_c_zvector) :: xh - - type(psb_z_vect_type), pointer :: vp - complex(psb_dpk_), allocatable :: fv(:) - integer(psb_c_ipk_) :: info, sz - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - fv = vp%get_vect() - sz = size(fv) - v(1:sz) = fv(1:sz) - end if - - end function psb_c_zvect_f_get_cpy - - - function psb_c_zvect_zero(xh) bind(c) result(res) - implicit none - - integer(psb_c_ipk_) :: res - type(psb_c_zvector) :: xh - - type(psb_z_vect_type), pointer :: vp - integer(psb_c_ipk_) :: info - - res = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - call vp%zero() - end if - - end function psb_c_zvect_zero - - function psb_c_zvect_f_get_pnt(xh) bind(c) result(res) - implicit none - - type(c_ptr) :: res - type(psb_c_zvector) :: xh - - type(psb_z_vect_type), pointer :: vp - - res = c_null_ptr - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,vp) - if(vp%is_dev()) call vp%sync() - res = c_loc(vp%v%v) - end if - - end function psb_c_zvect_f_get_pnt - - - function psb_c_zmat_get_nrows(mh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zspmat) :: mh - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - res = ap%get_nrows() - - end function psb_c_zmat_get_nrows - - - function psb_c_zmat_get_ncols(mh) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - type(psb_c_zspmat) :: mh - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - res = ap%get_ncols() - - end function psb_c_zmat_get_ncols - - - function psb_c_zmat_name_print(mh,name) bind(c) result(res) - use psb_base_mod - use psb_objhandle_mod - implicit none - integer(psb_c_ipk_) :: res - - character(c_char) :: name(*) - type(psb_c_zspmat) :: mh - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info - character(1024) :: fname - - res = 0 - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - call psb_stringc2f(name,fname) - - call ap%print(fname,head='PSBLAS Cbinding Interface') - - end function psb_c_zmat_name_print - - function psb_c_zvect_set_scal(x,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 - complex(c_double_complex), value :: val - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val) - - info = 0 - - end function psb_c_zvect_set_scal - - function psb_c_zvect_set_scal_bound(x,val,ifirst,ilast) 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 :: ifirst, ilast - complex(c_double_complex) :: val - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val,first=ifirst,last=ilast) - - info = 0 - - end function psb_c_zvect_set_scal_bound - - function psb_c_zvect_set_vect(x,val,n) 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 :: n - complex(c_double_complex) :: val(*) - - info = -1; - - if (c_associated(x%item)) then - call c_f_pointer(x%item,xp) - else - return - end if - - call xp%set(val(1:n)) - - info = 0 - - 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 + interface + module function psb_c_zvect_get_nrows(xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + + type(psb_z_vect_type), pointer :: vp + integer(psb_c_ipk_) :: info + end function psb_c_zvect_get_nrows + end interface + + interface + module function psb_c_zvect_f_get_cpy(v,xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + complex(c_double_complex) :: v(*) + type(psb_c_zvector) :: xh + end function psb_c_zvect_f_get_cpy + end interface + + + interface + module function psb_c_zvect_zero(xh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + end function psb_c_zvect_zero + end interface + + interface + module function psb_c_zvect_f_get_pnt(xh) bind(c) result(res) + type(c_ptr) :: res + type(psb_c_zvector) :: xh + end function psb_c_zvect_f_get_pnt + end interface + + interface + module function psb_c_zmat_get_nrows(mh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: mh + end function psb_c_zmat_get_nrows + end interface + + interface + module function psb_c_zmat_get_ncols(mh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: mh + end function psb_c_zmat_get_ncols + end interface + + interface + module function psb_c_zmat_name_print(mh,name) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: mh + character(c_char) :: name(*) + end function psb_c_zmat_name_print + end interface + + interface + module function psb_c_zvect_set_scal(x,val) bind(c) result(info) + type(psb_c_zvector) :: x + integer(psb_c_ipk_) :: info + complex(c_double_complex), value :: val + end function psb_c_zvect_set_scal + end interface + + interface + module function psb_c_zvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info) + type(psb_c_zvector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: ifirst, ilast + complex(c_double_complex) :: val + end function psb_c_zvect_set_scal_bound + end interface + + interface + module function psb_c_zvect_set_vect(x,val,n) bind(c) result(info) + type(psb_c_zvector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: n + complex(c_double_complex) :: val(*) + end function psb_c_zvect_set_vect + end interface + + interface + module function psb_c_zvect_set_entry(x,index,val) bind(c) result(info) + type(psb_c_zvector) :: x + integer(psb_c_ipk_) :: info + integer(psb_c_ipk_), value :: index + complex(c_double_complex), value :: val + end function psb_c_zvect_set_entry + end interface - 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 - - integer(psb_c_ipk_) :: info - type(psb_c_zvector) :: xh,yh - - type(psb_z_vect_type), pointer :: xp,yp - - info = -1 - - if (c_associated(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - if (c_associated(yh%item)) then - call c_f_pointer(yh%item,yp) - else - return - end if - call xp%clone(yp,info) - - end function psb_c_zvect_clone + interface + module function psb_c_zvect_get_entry(x,index) bind(c) result(res) + type(psb_c_zvector) :: x + integer(psb_c_ipk_), value :: index + complex(c_double_complex) :: res + end function psb_c_zvect_get_entry + end interface + + interface + module function psb_c_zvect_clone(xh,yh) bind(c) result(info) + integer(psb_c_ipk_) :: info + type(psb_c_zvector) :: xh,yh + end function psb_c_zvect_clone + end interface end module psb_z_serial_cbind_mod diff --git a/cbind/base/psb_z_tools_cbind_mod.F90 b/cbind/base/psb_z_tools_cbind_mod.F90 index f37c6b68..c7bc6bfd 100644 --- a/cbind/base/psb_z_tools_cbind_mod.F90 +++ b/cbind/base/psb_z_tools_cbind_mod.F90 @@ -8,604 +8,145 @@ module psb_z_tools_cbind_mod use psb_cuda_mod #endif -contains - ! Should define geall_opt with DUPL argument - function psb_c_zgeall(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_zgeall - - function psb_c_zgeall_remote(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info,bldmode=psb_matbld_remote_,dupl=psb_dupl_add_) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_zgeall_remote - - function psb_c_zgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: dupl - integer(psb_c_ipk_), value :: bldmode - - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - return - end if - allocate(xp) - call psb_geall(xp,descp,info,bldmode=bldmode,dupl=dupl) - xh%item = c_loc(xp) - res = min(0,info) - - return - end function psb_c_zgeall_remote_options - - function psb_c_zgeasb(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_geasb(xp,descp,info) - res = min(0,info) - - return - end function psb_c_zgeasb - - function psb_c_zgeasb_options(xh,cdh,dupl) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: dupl - - - type(psb_desc_type), pointer :: descp - type(psb_d_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_geasb(xp,descp,info,dupl=dupl) - res = min(0,info) - - return - end function psb_c_zgeasb_options - - function psb_c_zgeasb_options_format(xh,cdh,dupl,format) bind(c) result(res) - ! Takes into account format argument as a c string, and uses it to call the appropriate psb_geasb - ! with mold argument - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - character(kind=c_char), dimension(*) :: format - integer(psb_c_ipk_), value :: dupl - - ! Local variables - character(len=6) :: fformat - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - ! mold variables -#ifdef PSB_HAVE_CUDA - type(psb_z_vect_cuda), target :: vgpu -#endif - type(psb_z_base_vect_type), target :: vect - class(psb_z_base_vect_type), pointer :: vmold - - ! Select mold based on format - call psb_stringc2f(format,fformat) - - select case (psb_toupper(fformat)) -#ifdef PSB_HAVE_CUDA - case('GPU','DEVICE') - vmold => vgpu -#endif - case('CPU','HOST') - vmold => vect - case default - write(psb_out_unit,*) 'psb_c_zgeasb_options_format: Unknown format ',fformat - vmold => vect - end select - 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 - - call psb_geasb(xp,descp,info,dupl=dupl,mold=vmold) - res = min(0,info) - - return - end function psb_c_zgeasb_options_format - - - function psb_c_zgefree(xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: info - - 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 - - call psb_gefree(xp,descp,info) - res = min(0,info) - deallocate(xp,stat=info) - res = min(0,info) - xh%item = c_null_ptr - - return - end function psb_c_zgefree - - - function psb_c_zgeins(nz,irw,val,xh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*) - complex(c_double_complex) :: val(*) - type(psb_c_zvector) :: xh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_z_vect_type), pointer :: xp - integer(psb_c_ipk_) :: ixb, info - - res = -1 - info = 0 - 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 - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_geins(nz,irw(1:nz),val(1:nz),& - & xp,descp,info) - else - call psb_geins(nz,(irw(1:nz)+(1-ixb)),val(1:nz),& - & xp,descp,info) - end if - - res = min(0,info) - - return - end function psb_c_zgeins - - function psb_c_zspall(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - return - end if - allocate(ap) - call psb_spall(ap,descp,info) - mh%item = c_loc(ap) - res = min(0,info) - - return - end function psb_c_zspall - - - function psb_c_zspall_remote(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - return - end if - allocate(ap) - call psb_spall(ap,descp,info,bldmode=psb_matbld_remote_,dupl=psb_dupl_add_) - mh%item = c_loc(ap) - res = min(0,info) - - return - end function psb_c_zspall_remote - - function psb_c_zspasb(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - call psb_spasb(ap,descp,info) - res = min(0,info) - return - end function psb_c_zspasb - - function psb_c_zspfree(mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - call psb_spfree(ap,descp,info) - res = min(0,info) - deallocate(ap,stat=info) - mh%item=c_null_ptr - return - end function psb_c_zspfree - - - - - function psb_c_zspasb_opt(mh,cdh,afmt,upd,dupl) bind(c) result(res) - -#if 0 -#ifdef PSB_HAVE_LIBRSB - use psb_z_rsb_mat_mod -#endif -#endif -#if defined(PSB_HAVE_CUDA) - use psb_cuda_mod -#endif - use psb_ext_mod - implicit none - integer(psb_c_ipk_) :: res - type(psb_c_zspmat) :: mh - type(psb_c_descriptor) :: cdh - integer(psb_c_ipk_), value :: upd,dupl - character(c_char) :: afmt(*) - integer(psb_c_ipk_) :: info,n - character(len=5) :: fafmt - integer(psb_ipk_), parameter :: hksz = 32 - ! mold variables -#if 0 -#ifdef PSB_HAVE_LIBRSB - type(psb_z_rsb_sparse_mat) :: arsb -#endif -#endif - type(psb_z_ell_sparse_mat), target :: aell - type(psb_z_csr_sparse_mat), target :: acsr - type(psb_z_csc_sparse_mat), target :: acsc - type(psb_z_coo_sparse_mat), target :: acoo - type(psb_z_hll_sparse_mat), target :: ahll - type(psb_z_hdia_sparse_mat), target :: ahdia - type(psb_z_dns_sparse_mat), target :: adns -#if defined(PSB_HAVE_CUDA) - type(psb_z_cuda_hlg_sparse_mat), target :: ahlg - type(psb_z_cuda_csrg_sparse_mat), target :: acsrg - type(psb_z_cuda_elg_sparse_mat), target :: aelg -#endif - class(psb_z_base_sparse_mat), pointer :: amold - !Local variables - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - call psb_stringc2f(afmt,fafmt) - - ! Set the mold variable based on afmt - select case (psb_toupper(fafmt)) -#if defined(PSB_HAVE_CUDA) - case('ELG') - amold => aelg - case('HLG') - call psi_set_hksz(hksz) - amold => ahlg - case('CSRG') - amold => acsrg - case('ELL') - amold => aell - case('HLL') - call psi_set_hksz(hksz) - amold => ahll - case('CSR') - amold => acsr - case('CSC') - amold => acsc - case('DNS') - amold => adns - case default - write(*,*) 'Unknown format defaulting to HLG' - amold => ahlg -#else - case('ELL') - amold => aell - case('HLL') - call psi_set_hksz(hksz) - amold => ahll - amold => ahdia - case('CSR') - amold => acsr - case('CSC') - amold => acsc - case('DNS') - amold => adns - case default - write(*,*) 'Unknown format defaulting to CSR' - amold => acsr -#endif - end select - - select case(fafmt) -#if 0 -#ifdef PSB_HAVE_LIBRSB - case('RSB') - call psb_spasb(double_spmat_pool(mh)%item,descriptor_pool(cdh)%item,info,& - & upd=upd,mold=arsb) -#endif -#endif - case('ELL','HLL','CSR','DNS','CSC') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) -#if defined(PSB_HAVE_CUDA) - case('ELG','HLG','CSRG') - call psb_spasb(ap,descp,info,upd=upd,mold=amold) -#endif - case default - write(psb_out_unit,*) 'psb_c_zspasb_opt: Unknown format ',fafmt - call psb_spasb(ap,descp,info,afmt=fafmt,upd=upd,dupl=dupl) - end select - - res = min(0,info) - - return - end function psb_c_zspasb_opt - - - function psb_c_zspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - integer(psb_c_ipk_), value :: nz - integer(psb_c_lpk_) :: irw(*), icl(*) - complex(c_double_complex) :: val(*) - type(psb_c_zspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - integer(psb_c_ipk_) :: ixb,info,n - - res = -1 - if (c_associated(cdh%item)) then - call c_f_pointer(cdh%item,descp) - else - return - end if - if (c_associated(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_spins(nz,irw(1:nz),icl(1:nz),val(1:nz),ap,descp,info) - else - call psb_spins(nz,(irw(1:nz)+(1-ixb)),(icl(1:nz)+(1-ixb)),val(1:nz),ap,descp,info) - end if - res = min(0,info) - return - end function psb_c_zspins - - - function psb_c_zsprn(mh,cdh,clear) bind(c) result(res) - - implicit none - integer(psb_c_ipk_) :: res - logical(c_bool), value :: clear - type(psb_c_zspmat) :: mh - type(psb_c_descriptor) :: cdh - - type(psb_desc_type), pointer :: descp - type(psb_zspmat_type), pointer :: ap - 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(mh%item)) then - call c_f_pointer(mh%item,ap) - else - return - end if - - fclear = clear - call psb_sprn(ap,descp,info,clear=fclear) - res = min(0,info) - - return - end function psb_c_zsprn + interface + module function psb_c_zgeall(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zgeall + end interface + + interface + module function psb_c_zgeall_remote(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + + end function psb_c_zgeall_remote + end interface + + interface + module function psb_c_zgeall_remote_options(xh,cdh,bldmode,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: dupl + integer(psb_c_ipk_), value :: bldmode + end function psb_c_zgeall_remote_options + end interface + + interface + module function psb_c_zgeasb(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zgeasb + end interface + + interface + module function psb_c_zgeasb_options(xh,cdh,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: dupl + end function psb_c_zgeasb_options + end interface + + interface + module function psb_c_zgeasb_options_format(xh,cdh,dupl,format) bind(c) result(res) + ! Takes into account format argument as a c string, and uses it to call the appropriate psb_geasb + ! with mold argument + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + character(kind=c_char), dimension(*) :: format + integer(psb_c_ipk_), value :: dupl + end function psb_c_zgeasb_options_format + end interface + + interface + module function psb_c_zgefree(xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zgefree + end interface + + interface + module function psb_c_zgeins(nz,irw,val,xh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: nz + integer(psb_c_lpk_) :: irw(*) + complex(c_double_complex) :: val(*) + type(psb_c_zvector) :: xh + type(psb_c_descriptor) :: cdh + end function psb_c_zgeins + end interface + + interface + module function psb_c_zspall(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_zspall + end interface + + interface + module function psb_c_zspall_remote(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_zspall_remote + end interface + + interface + module function psb_c_zspasb(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_zspasb + end interface + + interface + module function psb_c_zspfree(mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_zspfree + end interface + + interface + module function psb_c_zspasb_opt(mh,cdh,afmt,upd,dupl) bind(c) result(res) + integer(psb_c_ipk_) :: res + type(psb_c_zspmat) :: mh + type(psb_c_descriptor) :: cdh + integer(psb_c_ipk_), value :: upd,dupl + character(c_char) :: afmt(*) + end function psb_c_zspasb_opt + end interface + + interface + module function psb_c_zspins(nz,irw,icl,val,mh,cdh) bind(c) result(res) + integer(psb_c_ipk_) :: res + integer(psb_c_ipk_), value :: nz + integer(psb_c_lpk_) :: irw(*), icl(*) + complex(c_double_complex) :: val(*) + type(psb_c_zspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_zspins + end interface + + interface + module function psb_c_zsprn(mh,cdh,clear) bind(c) result(res) + integer(psb_c_ipk_) :: res + logical(c_bool), value :: clear + type(psb_c_zspmat) :: mh + type(psb_c_descriptor) :: cdh + end function psb_c_zsprn + end interface !!$ -!!$ function psb_c_zspprint(mh) bind(c) result(res) +!!$ module function psb_c_zspprint(mh) bind(c) result(res) !!$ !!$ implicit none !!$ integer(psb_c_ipk_) :: res @@ -624,109 +165,32 @@ contains !!$ return !!$ end function psb_c_zspprint - function psb_c_zgetelem(xh,index,cdh) bind(c) result(res) - implicit none - - type(psb_c_zvector) :: xh - integer(psb_c_lpk_), value :: index - type(psb_c_descriptor) :: cdh - complex(c_double_complex) :: res - - type(psb_z_vect_type), pointer :: xp - 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(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - res = psb_getelem(xp,index,descp,info) - else - res = psb_getelem(xp,index+(1-ixb),descp,info) - end if - - return - - end function psb_c_zgetelem - - function psb_c_zsetelem(index,val,xh,cdh) bind(c) result(res) - implicit none - - type(psb_c_zvector) :: xh - integer(psb_c_lpk_), value :: index - type(psb_c_descriptor) :: cdh - complex(c_double_complex), value :: val - integer(psb_c_ipk_) :: res - - type(psb_z_vect_type), pointer :: xp - 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(xh%item)) then - call c_f_pointer(xh%item,xp) - else - return - end if - - ixb = psb_c_get_index_base() - if (ixb == 1) then - call psb_setelem(index,val,xp,descp,info) - else - call psb_setelem(index+(1-ixb),val,xp,descp,info) - end if - res=info - return - - end function psb_c_zsetelem - - 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 + interface + module function psb_c_zgetelem(xh,index,cdh) bind(c) result(res) + type(psb_c_zvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + complex(c_double_complex) :: res + end function psb_c_zgetelem + end interface + + interface + module function psb_c_zsetelem(index,val,xh,cdh) bind(c) result(res) + type(psb_c_zvector) :: xh + integer(psb_c_lpk_), value :: index + type(psb_c_descriptor) :: cdh + complex(c_double_complex), value :: val + integer(psb_c_ipk_) :: res + end function psb_c_zsetelem + end interface + + interface + module function psb_c_zmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res) + type(psb_c_zspmat) :: ah + integer(psb_c_lpk_), value :: rowindex, colindex + type(psb_c_descriptor) :: cdh + complex(c_double_complex) :: res + end function psb_c_zmatgetelem + end interface end module psb_z_tools_cbind_mod