Refactor CBIND
Salvatore Filippone
4 weeks ago
parent
90b6a1637d
commit
5d7b10683a
@ -0,0 +1,238 @@
|
||||
submodule (psb_c_comm_cbind_mod) psb_c_comm_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_objhandle_mod
|
||||
|
||||
contains
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
end submodule psb_c_comm_cbind_impl
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,283 @@
|
||||
submodule (psb_c_serial_cbind_mod) psb_c_serial_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_objhandle_mod
|
||||
use psb_base_tools_cbind_mod
|
||||
|
||||
contains
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module function psb_c_cmat_get_nrows(mh) bind(c) result(res)
|
||||
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
|
||||
|
||||
|
||||
module function psb_c_cmat_get_ncols(mh) bind(c) result(res)
|
||||
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
|
||||
|
||||
module function psb_c_cmat_name_print(mh,name) bind(c) result(res)
|
||||
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
|
||||
|
||||
module function psb_c_cvect_set_scal(x,val) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_cvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_cvect_set_vect(x,val,n) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_cvect_set_entry(x,index,val) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_cvect_get_entry(x,index) bind(c) result(res)
|
||||
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
|
||||
|
||||
module 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
|
||||
|
||||
end submodule psb_c_serial_cbind_impl
|
||||
@ -0,0 +1,732 @@
|
||||
submodule ( psb_c_tools_cbind_mod) psb_c_tools_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_cpenv_mod
|
||||
use psb_objhandle_mod
|
||||
use psb_base_tools_cbind_mod
|
||||
#ifdef PSB_HAVE_CUDA
|
||||
use psb_cuda_mod
|
||||
#endif
|
||||
|
||||
contains
|
||||
|
||||
! Should define geall_opt with DUPL argument
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
!!$
|
||||
!!$ module function psb_c_cspprint(mh) bind(c) result(res)
|
||||
!!$
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_c_ipk_) :: res
|
||||
!!$ integer(psb_c_ipk_), value :: mh
|
||||
!!$ integer(psb_c_ipk_) :: info
|
||||
!!$
|
||||
!!$
|
||||
!!$ res = -1
|
||||
!!$ call psb_check_double_spmat_handle(mh,info)
|
||||
!!$ if (info < 0) return
|
||||
!!$
|
||||
!!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat')
|
||||
!!$
|
||||
!!$ res = 0
|
||||
!!$
|
||||
!!$ 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
|
||||
|
||||
module 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
|
||||
|
||||
module function psb_c_cmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res)
|
||||
implicit none
|
||||
|
||||
type(psb_c_cspmat) :: ah
|
||||
integer(psb_c_lpk_), value :: rowindex, colindex
|
||||
type(psb_c_descriptor) :: cdh
|
||||
complex(c_float_complex) :: res
|
||||
type(psb_cspmat_type), pointer :: ap
|
||||
type(psb_desc_type), pointer :: descp
|
||||
integer(psb_c_ipk_) :: info, ixb
|
||||
|
||||
res = -1
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
end if
|
||||
|
||||
ixb = psb_c_get_index_base()
|
||||
if (ixb == 1) then
|
||||
res = psb_getelem(ap,rowindex,colindex,descp,info)
|
||||
else
|
||||
res = psb_getelem(ap,rowindex+(1-ixb),colindex+(1-ixb),descp,info)
|
||||
end if
|
||||
|
||||
return
|
||||
|
||||
end function psb_c_cmatgetelem
|
||||
|
||||
end submodule psb_c_tools_cbind_impl
|
||||
@ -0,0 +1,238 @@
|
||||
submodule (psb_d_comm_cbind_mod) psb_d_comm_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_objhandle_mod
|
||||
|
||||
contains
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
end submodule psb_d_comm_cbind_impl
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,284 @@
|
||||
submodule (psb_d_serial_cbind_mod) psb_d_serial_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_objhandle_mod
|
||||
use psb_base_tools_cbind_mod
|
||||
|
||||
contains
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module function psb_c_dmat_get_nrows(mh) bind(c) result(res)
|
||||
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
|
||||
|
||||
|
||||
module function psb_c_dmat_get_ncols(mh) bind(c) result(res)
|
||||
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
|
||||
|
||||
module function psb_c_dmat_name_print(mh,name) bind(c) result(res)
|
||||
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
|
||||
|
||||
module function psb_c_dvect_set_scal(x,val) bind(c) result(info)
|
||||
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
|
||||
|
||||
write(0,*) 'C_set_scal ',val,size(xp%v%v)
|
||||
call xp%set(val)
|
||||
|
||||
info = 0
|
||||
|
||||
end function psb_c_dvect_set_scal
|
||||
|
||||
module function psb_c_dvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_dvect_set_vect(x,val,n) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_dvect_set_entry(x,index,val) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_dvect_get_entry(x,index) bind(c) result(res)
|
||||
implicit none
|
||||
|
||||
type(psb_c_dvector) :: x
|
||||
type(psb_d_vect_type), pointer :: xp
|
||||
integer(psb_c_ipk_), value :: index
|
||||
real(c_double) :: res
|
||||
integer(psb_c_ipk_) :: ixb
|
||||
|
||||
if (c_associated(x%item)) then
|
||||
call c_f_pointer(x%item,xp)
|
||||
else
|
||||
return
|
||||
end if
|
||||
|
||||
ixb = psb_c_get_index_base()
|
||||
res = xp%get_entry((index+(1-ixb)))
|
||||
end function psb_c_dvect_get_entry
|
||||
|
||||
module 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
|
||||
|
||||
end submodule psb_d_serial_cbind_impl
|
||||
@ -0,0 +1,742 @@
|
||||
submodule ( psb_d_tools_cbind_mod) psb_d_tools_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_cpenv_mod
|
||||
use psb_objhandle_mod
|
||||
use psb_base_tools_cbind_mod
|
||||
#ifdef PSB_HAVE_CUDA
|
||||
use psb_cuda_mod
|
||||
#endif
|
||||
|
||||
contains
|
||||
|
||||
! Should define geall_opt with DUPL argument
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
!!$
|
||||
!!$ module function psb_c_dspprint(mh) bind(c) result(res)
|
||||
!!$
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_c_ipk_) :: res
|
||||
!!$ integer(psb_c_ipk_), value :: mh
|
||||
!!$ integer(psb_c_ipk_) :: info
|
||||
!!$
|
||||
!!$
|
||||
!!$ res = -1
|
||||
!!$ call psb_check_double_spmat_handle(mh,info)
|
||||
!!$ if (info < 0) return
|
||||
!!$
|
||||
!!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat')
|
||||
!!$
|
||||
!!$ res = 0
|
||||
!!$
|
||||
!!$ 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
|
||||
|
||||
module 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
|
||||
|
||||
module function psb_c_dmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res)
|
||||
implicit none
|
||||
|
||||
type(psb_c_dspmat) :: ah
|
||||
integer(psb_c_lpk_), value :: rowindex, colindex
|
||||
type(psb_c_descriptor) :: cdh
|
||||
real(c_double) :: res
|
||||
type(psb_dspmat_type), pointer :: ap
|
||||
type(psb_desc_type), pointer :: descp
|
||||
integer(psb_c_ipk_) :: info, ixb
|
||||
|
||||
res = -1
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
end if
|
||||
|
||||
ixb = psb_c_get_index_base()
|
||||
if (ixb == 1) then
|
||||
res = psb_getelem(ap,rowindex,colindex,descp,info)
|
||||
else
|
||||
res = psb_getelem(ap,rowindex+(1-ixb),colindex+(1-ixb),descp,info)
|
||||
end if
|
||||
|
||||
return
|
||||
|
||||
end function psb_c_dmatgetelem
|
||||
|
||||
end submodule psb_d_tools_cbind_impl
|
||||
@ -0,0 +1,238 @@
|
||||
submodule (psb_s_comm_cbind_mod) psb_s_comm_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_objhandle_mod
|
||||
|
||||
contains
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
end submodule psb_s_comm_cbind_impl
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,283 @@
|
||||
submodule (psb_s_serial_cbind_mod) psb_s_serial_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_objhandle_mod
|
||||
use psb_base_tools_cbind_mod
|
||||
|
||||
contains
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module function psb_c_smat_get_nrows(mh) bind(c) result(res)
|
||||
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
|
||||
|
||||
|
||||
module function psb_c_smat_get_ncols(mh) bind(c) result(res)
|
||||
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
|
||||
|
||||
module function psb_c_smat_name_print(mh,name) bind(c) result(res)
|
||||
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
|
||||
|
||||
module function psb_c_svect_set_scal(x,val) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_svect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_svect_set_vect(x,val,n) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_svect_set_entry(x,index,val) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_svect_get_entry(x,index) bind(c) result(res)
|
||||
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
|
||||
|
||||
module 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
|
||||
|
||||
end submodule psb_s_serial_cbind_impl
|
||||
@ -0,0 +1,742 @@
|
||||
submodule ( psb_s_tools_cbind_mod) psb_s_tools_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_cpenv_mod
|
||||
use psb_objhandle_mod
|
||||
use psb_base_tools_cbind_mod
|
||||
#ifdef PSB_HAVE_CUDA
|
||||
use psb_cuda_mod
|
||||
#endif
|
||||
|
||||
contains
|
||||
|
||||
! Should define geall_opt with DUPL argument
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
!!$
|
||||
!!$ module function psb_c_sspprint(mh) bind(c) result(res)
|
||||
!!$
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_c_ipk_) :: res
|
||||
!!$ integer(psb_c_ipk_), value :: mh
|
||||
!!$ integer(psb_c_ipk_) :: info
|
||||
!!$
|
||||
!!$
|
||||
!!$ res = -1
|
||||
!!$ call psb_check_double_spmat_handle(mh,info)
|
||||
!!$ if (info < 0) return
|
||||
!!$
|
||||
!!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat')
|
||||
!!$
|
||||
!!$ res = 0
|
||||
!!$
|
||||
!!$ 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
|
||||
|
||||
module 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
|
||||
|
||||
module function psb_c_smatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res)
|
||||
implicit none
|
||||
|
||||
type(psb_c_sspmat) :: ah
|
||||
integer(psb_c_lpk_), value :: rowindex, colindex
|
||||
type(psb_c_descriptor) :: cdh
|
||||
real(c_float) :: res
|
||||
type(psb_sspmat_type), pointer :: ap
|
||||
type(psb_desc_type), pointer :: descp
|
||||
integer(psb_c_ipk_) :: info, ixb
|
||||
|
||||
res = -1
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
end if
|
||||
|
||||
ixb = psb_c_get_index_base()
|
||||
if (ixb == 1) then
|
||||
res = psb_getelem(ap,rowindex,colindex,descp,info)
|
||||
else
|
||||
res = psb_getelem(ap,rowindex+(1-ixb),colindex+(1-ixb),descp,info)
|
||||
end if
|
||||
|
||||
return
|
||||
|
||||
end function psb_c_smatgetelem
|
||||
|
||||
end submodule psb_s_tools_cbind_impl
|
||||
@ -0,0 +1,238 @@
|
||||
submodule (psb_z_comm_cbind_mod) psb_z_comm_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_objhandle_mod
|
||||
|
||||
contains
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
end submodule psb_z_comm_cbind_impl
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,283 @@
|
||||
submodule (psb_z_serial_cbind_mod) psb_z_serial_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_objhandle_mod
|
||||
use psb_base_tools_cbind_mod
|
||||
|
||||
contains
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module function psb_c_zmat_get_nrows(mh) bind(c) result(res)
|
||||
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
|
||||
|
||||
|
||||
module function psb_c_zmat_get_ncols(mh) bind(c) result(res)
|
||||
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
|
||||
|
||||
module function psb_c_zmat_name_print(mh,name) bind(c) result(res)
|
||||
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
|
||||
|
||||
module function psb_c_zvect_set_scal(x,val) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_zvect_set_scal_bound(x,val,ifirst,ilast) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_zvect_set_vect(x,val,n) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_zvect_set_entry(x,index,val) bind(c) result(info)
|
||||
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
|
||||
|
||||
module function psb_c_zvect_get_entry(x,index) bind(c) result(res)
|
||||
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
|
||||
|
||||
module 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
|
||||
|
||||
end submodule psb_z_serial_cbind_impl
|
||||
@ -0,0 +1,732 @@
|
||||
submodule ( psb_z_tools_cbind_mod) psb_z_tools_cbind_impl
|
||||
use iso_c_binding
|
||||
use psb_base_mod
|
||||
use psb_cpenv_mod
|
||||
use psb_objhandle_mod
|
||||
use psb_base_tools_cbind_mod
|
||||
#ifdef PSB_HAVE_CUDA
|
||||
use psb_cuda_mod
|
||||
#endif
|
||||
|
||||
contains
|
||||
|
||||
! Should define geall_opt with DUPL argument
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
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
|
||||
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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
|
||||
|
||||
module 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
|
||||
!!$
|
||||
!!$ module function psb_c_zspprint(mh) bind(c) result(res)
|
||||
!!$
|
||||
!!$ implicit none
|
||||
!!$ integer(psb_c_ipk_) :: res
|
||||
!!$ integer(psb_c_ipk_), value :: mh
|
||||
!!$ integer(psb_c_ipk_) :: info
|
||||
!!$
|
||||
!!$
|
||||
!!$ res = -1
|
||||
!!$ call psb_check_double_spmat_handle(mh,info)
|
||||
!!$ if (info < 0) return
|
||||
!!$
|
||||
!!$ call psb_csprt(0,double_spmat_pool(mh)%item,head='Debug mat')
|
||||
!!$
|
||||
!!$ res = 0
|
||||
!!$
|
||||
!!$ 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
|
||||
|
||||
module 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
|
||||
|
||||
module function psb_c_zmatgetelem(ah,rowindex,colindex,cdh) bind(c) result(res)
|
||||
implicit none
|
||||
|
||||
type(psb_c_zspmat) :: ah
|
||||
integer(psb_c_lpk_), value :: rowindex, colindex
|
||||
type(psb_c_descriptor) :: cdh
|
||||
complex(c_double_complex) :: res
|
||||
type(psb_zspmat_type), pointer :: ap
|
||||
type(psb_desc_type), pointer :: descp
|
||||
integer(psb_c_ipk_) :: info, ixb
|
||||
|
||||
res = -1
|
||||
if (c_associated(cdh%item)) then
|
||||
call c_f_pointer(cdh%item,descp)
|
||||
else
|
||||
return
|
||||
end if
|
||||
if (c_associated(ah%item)) then
|
||||
call c_f_pointer(ah%item,ap)
|
||||
else
|
||||
return
|
||||
end if
|
||||
|
||||
ixb = psb_c_get_index_base()
|
||||
if (ixb == 1) then
|
||||
res = psb_getelem(ap,rowindex,colindex,descp,info)
|
||||
else
|
||||
res = psb_getelem(ap,rowindex+(1-ixb),colindex+(1-ixb),descp,info)
|
||||
end if
|
||||
|
||||
return
|
||||
|
||||
end function psb_c_zmatgetelem
|
||||
|
||||
end submodule psb_z_tools_cbind_impl
|
||||
Loading…
Reference in New Issue