fdurastante
/
psblas3
mirror of https://github.com/sfilippone/psblas3.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

Refactor cbind/base modules

Browse Source
merge-maint-par
Salvatore Filippone 2 weeks ago
parent dd6dd4cdfe
commit 90b6a1637d
19 changed files with 2703 additions and 10136 deletions
Show Stats Download Patch File Download Diff File

6
base/CMakeLists.txt
Unescape Escape View File

@ -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

16
cbind/CMakeLists.txt
Unescape Escape View File

@ -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

28
cbind/base/Makefile
Unescape Escape View File

@ -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

295
cbind/base/psb_c_comm_cbind_mod.f90
Unescape Escape View File

@ -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

1582
cbind/base/psb_c_psblas_cbind_mod.f90
View File

File diff suppressed because it is too large Load Diff

389
cbind/base/psb_c_serial_cbind_mod.F90
Unescape Escape View File

@ -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

864
cbind/base/psb_c_tools_cbind_mod.F90
Unescape Escape View File

@ -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

295
cbind/base/psb_d_comm_cbind_mod.f90
Unescape Escape View File

@ -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

1706
cbind/base/psb_d_psblas_cbind_mod.f90
View File

File diff suppressed because it is too large Load Diff

390
cbind/base/psb_d_serial_cbind_mod.F90
Unescape Escape View File

@ -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

874
cbind/base/psb_d_tools_cbind_mod.F90
Unescape Escape View File

@ -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

295
cbind/base/psb_s_comm_cbind_mod.f90
Unescape Escape View File

@ -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

1706
cbind/base/psb_s_psblas_cbind_mod.f90
View File

File diff suppressed because it is too large Load Diff

389
cbind/base/psb_s_serial_cbind_mod.F90
Unescape Escape View File

@ -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

874
cbind/base/psb_s_tools_cbind_mod.F90
Unescape Escape View File

@ -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

295
cbind/base/psb_z_comm_cbind_mod.f90
Unescape Escape View File

@ -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

1582
cbind/base/psb_z_psblas_cbind_mod.f90
View File

File diff suppressed because it is too large Load Diff

389
cbind/base/psb_z_serial_cbind_mod.F90
Unescape Escape View File

@ -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

864
cbind/base/psb_z_tools_cbind_mod.F90
Unescape Escape View File

@ -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

Write Preview
Loading…
Cancel
Save