You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
552 lines
14 KiB
Fortran
552 lines
14 KiB
Fortran
module psb_base_tools_cbind_mod
|
|
use iso_c_binding
|
|
use psb_base_mod
|
|
use psb_objhandle_mod
|
|
use psb_cpenv_mod
|
|
#ifdef PSB_HAVE_CUDA
|
|
use psb_cuda_mod
|
|
#endif
|
|
contains
|
|
|
|
! Aggiungere funzione per estrarre comunicatore
|
|
|
|
function psb_c_error() bind(c) result(res)
|
|
implicit none
|
|
integer(psb_c_ipk_) :: res
|
|
res = 0
|
|
call psb_error()
|
|
end function psb_c_error
|
|
|
|
function psb_c_clean_errstack() bind(c) result(res)
|
|
implicit none
|
|
integer(psb_c_ipk_) :: res
|
|
res = 0
|
|
call psb_clean_errstack()
|
|
end function psb_c_clean_errstack
|
|
|
|
function psb_c_cdall_vg(ng,vg,cctxt,cdh) bind(c,name='psb_c_cdall_vg') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
integer(psb_c_lpk_), value :: ng
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_) :: vg(*)
|
|
type(psb_c_object_type) :: cdh
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: info
|
|
type(psb_ctxt_type) :: ctxt
|
|
ctxt = psb_c2f_ctxt(cctxt)
|
|
|
|
res = -1
|
|
if (ng <=0) then
|
|
write(0,*) 'Invalid size'
|
|
return
|
|
end if
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
call descp%free(info)
|
|
if (info == 0) deallocate(descp,stat=info)
|
|
if (info /= 0) return
|
|
end if
|
|
|
|
allocate(descp,stat=info)
|
|
if (info < 0) return
|
|
|
|
call psb_cdall(ctxt,descp,info,vg=vg(1:ng))
|
|
cdh%item = c_loc(descp)
|
|
res = info
|
|
|
|
end function psb_c_cdall_vg
|
|
|
|
|
|
function psb_c_cdall_vl(nl,vl,cctxt,cdh) bind(c,name='psb_c_cdall_vl') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: nl
|
|
integer(psb_c_lpk_) :: vl(*)
|
|
type(psb_c_object_type) :: cdh
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: info, ixb
|
|
type(psb_ctxt_type) :: ctxt
|
|
ctxt = psb_c2f_ctxt(cctxt)
|
|
|
|
res = -1
|
|
if (nl <=0) then
|
|
write(0,*) 'Invalid size'
|
|
return
|
|
end if
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
call descp%free(info)
|
|
if (info == 0) deallocate(descp,stat=info)
|
|
if (info /= 0) return
|
|
end if
|
|
|
|
allocate(descp,stat=info)
|
|
if (info < 0) return
|
|
|
|
ixb = psb_c_get_index_base()
|
|
|
|
if (ixb == 1) then
|
|
call psb_cdall(ctxt,descp,info,vl=vl(1:nl))
|
|
else
|
|
call psb_cdall(ctxt,descp,info,vl=(vl(1:nl)+(1-ixb)))
|
|
end if
|
|
cdh%item = c_loc(descp)
|
|
res = info
|
|
|
|
end function psb_c_cdall_vl
|
|
|
|
function psb_c_cdall_vl_opt(nl,vl,cctxt,cdh) bind(c,name='psb_c_cdall_vl_opt') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: nl
|
|
integer(psb_c_lpk_) :: vl(*)
|
|
type(psb_c_object_type) :: cdh
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: info, ixb
|
|
type(psb_ctxt_type) :: ctxt
|
|
ctxt = psb_c2f_ctxt(cctxt)
|
|
|
|
res = -1
|
|
if (nl <=0) then
|
|
write(0,*) 'Invalid size'
|
|
return
|
|
end if
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
call descp%free(info)
|
|
if (info == 0) deallocate(descp,stat=info)
|
|
if (info /= 0) return
|
|
end if
|
|
|
|
allocate(descp,stat=info)
|
|
if (info < 0) return
|
|
|
|
ixb = psb_c_get_index_base()
|
|
|
|
if (ixb == 1) then
|
|
call psb_cdall(ctxt,descp,info,vl=vl(1:nl),globalcheck=.true.)
|
|
else
|
|
call psb_cdall(ctxt,descp,info,vl=(vl(1:nl)+(1-ixb)),globalcheck=.true.)
|
|
end if
|
|
cdh%item = c_loc(descp)
|
|
res = info
|
|
|
|
end function psb_c_cdall_vl_opt
|
|
|
|
function psb_c_cdall_vl_lidx(nl,vl,lidx,cctxt,cdh) bind(c,name='psb_c_cdall_vl_lidx') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: nl
|
|
integer(psb_c_lpk_) :: vl(*)
|
|
integer(psb_c_ipk_) :: lidx(*)
|
|
type(psb_c_object_type) :: cdh
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: info, ixb
|
|
type(psb_ctxt_type) :: ctxt
|
|
ctxt = psb_c2f_ctxt(cctxt)
|
|
|
|
res = -1
|
|
if (nl <=0) then
|
|
write(0,*) 'Invalid size'
|
|
return
|
|
end if
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
call descp%free(info)
|
|
if (info == 0) deallocate(descp,stat=info)
|
|
if (info /= 0) return
|
|
end if
|
|
|
|
allocate(descp,stat=info)
|
|
if (info < 0) return
|
|
|
|
ixb = psb_c_get_index_base()
|
|
|
|
if (ixb == 1) then
|
|
call psb_cdall(ctxt,descp,info,vl=vl(1:nl),lidx=lidx(1:nl))
|
|
else
|
|
call psb_cdall(ctxt,descp,info,vl=(vl(1:nl)+(1-ixb)),lidx=(lidx(1:nl)+(1-ixb)))
|
|
end if
|
|
cdh%item = c_loc(descp)
|
|
res = info
|
|
|
|
end function psb_c_cdall_vl_lidx
|
|
|
|
function psb_c_cdall_nl(nl,cctxt,cdh) bind(c,name='psb_c_cdall_nl') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: nl
|
|
type(psb_c_object_type) :: cdh
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: info
|
|
type(psb_ctxt_type) :: ctxt
|
|
ctxt = psb_c2f_ctxt(cctxt)
|
|
|
|
res = -1
|
|
if (nl <=0) then
|
|
write(0,*) 'Invalid size'
|
|
return
|
|
end if
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
call descp%free(info)
|
|
if (info == 0) deallocate(descp,stat=info)
|
|
if (info /= 0) return
|
|
end if
|
|
|
|
allocate(descp,stat=info)
|
|
if (info < 0) return
|
|
|
|
call psb_cdall(ctxt,descp,info,nl=nl)
|
|
cdh%item = c_loc(descp)
|
|
res = info
|
|
|
|
end function psb_c_cdall_nl
|
|
|
|
function psb_c_cdall_repl(n,cctxt,cdh) bind(c,name='psb_c_cdall_repl') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
integer(psb_c_lpk_), value :: n
|
|
type(psb_c_object_type), value :: cctxt
|
|
type(psb_c_object_type) :: cdh
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: info
|
|
type(psb_ctxt_type) :: ctxt
|
|
ctxt = psb_c2f_ctxt(cctxt)
|
|
|
|
|
|
res = -1
|
|
if (n <=0) then
|
|
write(0,*) 'Invalid size'
|
|
return
|
|
end if
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
call descp%free(info)
|
|
if (info == 0) deallocate(descp,stat=info)
|
|
if (info /= 0) return
|
|
end if
|
|
|
|
allocate(descp,stat=info)
|
|
if (info < 0) return
|
|
|
|
call psb_cdall(ctxt,descp,info,mg=n,repl=.true.)
|
|
cdh%item = c_loc(descp)
|
|
res = info
|
|
|
|
end function psb_c_cdall_repl
|
|
|
|
function psb_c_cdasb(cdh) bind(c,name='psb_c_cdasb') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
type(psb_c_object_type) :: cdh
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: info
|
|
|
|
res = -1
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
call psb_cdasb(descp,info)
|
|
res = info
|
|
end if
|
|
|
|
end function psb_c_cdasb
|
|
|
|
function psb_c_cdasb_format(cdh,format) bind(c,name='psb_c_cdasb_format') result(res)
|
|
use psb_base_string_cbind_mod, only: stringc2f
|
|
implicit none
|
|
! Takes as input the desired format bewten CPU or GPU, and assembles accordingly
|
|
! via the mold parameter of psb_cdasb
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
type(psb_c_object_type) :: cdh
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: info
|
|
character(c_char), dimension(*) :: format
|
|
|
|
! Local variables
|
|
character(len=6) :: fformat
|
|
! mold variables
|
|
#ifdef PSB_HAVE_CUDA
|
|
type(psb_i_vect_cuda), target :: ivgpu
|
|
#endif
|
|
type(psb_i_base_vect_type), target :: ivect
|
|
class(psb_i_base_vect_type), pointer :: imold
|
|
|
|
call stringc2f(format,fformat)
|
|
|
|
res = -1
|
|
select case (psb_toupper(fformat))
|
|
#ifdef PSB_HAVE_CUDA
|
|
case('GPU','DEVICE')
|
|
imold => ivgpu
|
|
#endif
|
|
case('CPU','HOST')
|
|
imold => ivect
|
|
case default
|
|
write(psb_out_unit,*) 'psb_c_cdasb_format: Unknown format ',fformat
|
|
imold => ivect
|
|
end select
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
call psb_cdasb(descp,info,mold=imold)
|
|
res = info
|
|
end if
|
|
|
|
end function psb_c_cdasb_format
|
|
|
|
function psb_c_cdfree(cdh) bind(c,name='psb_c_cdfree') result(res)
|
|
|
|
implicit none
|
|
integer(psb_c_ipk_) :: res
|
|
type(psb_c_object_type) :: cdh
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: info
|
|
|
|
res = -1
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
call descp%free(info)
|
|
if (info == 0) deallocate(descp,stat=info)
|
|
if (info /= 0) return
|
|
cdh%item = c_null_ptr
|
|
end if
|
|
|
|
res = info
|
|
return
|
|
end function psb_c_cdfree
|
|
|
|
function psb_c_cdins(nz,ia,ja,cdh) bind(c,name='psb_c_cdins') result(res)
|
|
|
|
implicit none
|
|
integer(psb_c_ipk_) :: res
|
|
integer(psb_c_ipk_), value :: nz
|
|
type(psb_c_object_type) :: cdh
|
|
integer(psb_c_lpk_) :: ia(*),ja(*)
|
|
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: ixb,info
|
|
|
|
res = -1
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
ixb = psb_c_get_index_base()
|
|
if (ixb == 1) then
|
|
call psb_cdins(nz,ia(1:nz),ja(1:nz),descp,info)
|
|
else
|
|
call psb_cdins(nz,(ia(1:nz)+(1-ixb)),(ja(1:nz)+(1-ixb)),descp,info)
|
|
end if
|
|
|
|
res = info
|
|
end if
|
|
return
|
|
end function psb_c_cdins
|
|
|
|
|
|
function psb_c_cdins_lidx(nz,ja,lidx,cdh) bind(c,name='psb_c_cdins_lidx') result(res)
|
|
|
|
implicit none
|
|
integer(psb_c_ipk_) :: res
|
|
integer(psb_c_ipk_), value :: nz
|
|
type(psb_c_object_type) :: cdh
|
|
integer(psb_c_lpk_) :: ja(*)
|
|
integer(psb_c_ipk_) :: lidx(*)
|
|
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: ixb,info
|
|
|
|
res = -1
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
ixb = psb_c_get_index_base()
|
|
|
|
if (ixb == 1) then
|
|
call psb_cdins(nz,ja(1:nz),descp,info,lidx=lidx(1:nz))
|
|
else
|
|
call psb_cdins(nz,(ja(1:nz)+(1-ixb)),descp,info,lidx=(lidx(1:nz)+(1-ixb)))
|
|
end if
|
|
|
|
res = info
|
|
end if
|
|
return
|
|
end function psb_c_cdins_lidx
|
|
|
|
function psb_c_cd_is_asb(cdh) bind(c,name='psb_c_cd_is_asb') result(res)
|
|
implicit none
|
|
|
|
logical(c_bool) :: res
|
|
type(psb_c_object_type) :: cdh
|
|
|
|
type(psb_desc_type), pointer :: descp
|
|
|
|
res = .false.
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
if (descp%is_asb()) then
|
|
res = .true.
|
|
else
|
|
res = .false.
|
|
end if
|
|
end if
|
|
|
|
end function psb_c_cd_is_asb
|
|
|
|
|
|
|
|
function psb_c_cd_get_local_rows(cdh) bind(c,name='psb_c_cd_get_local_rows') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
type(psb_c_object_type) :: cdh
|
|
|
|
type(psb_desc_type), pointer :: descp
|
|
integer :: info
|
|
|
|
res = -1
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
res = descp%get_local_rows()
|
|
|
|
end if
|
|
|
|
end function psb_c_cd_get_local_rows
|
|
|
|
|
|
|
|
function psb_c_cd_get_local_cols(cdh) bind(c,name='psb_c_cd_get_local_cols') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
type(psb_c_object_type) :: cdh
|
|
|
|
type(psb_desc_type), pointer :: descp
|
|
integer :: info
|
|
|
|
res = -1
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
res = descp%get_local_cols()
|
|
|
|
end if
|
|
|
|
end function psb_c_cd_get_local_cols
|
|
|
|
function psb_c_cd_get_global_rows(cdh) bind(c,name='psb_c_cd_get_global_rows') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_lpk_) :: res
|
|
type(psb_c_object_type) :: cdh
|
|
|
|
type(psb_desc_type), pointer :: descp
|
|
integer :: info
|
|
|
|
res = -1
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
res = descp%get_global_rows()
|
|
|
|
end if
|
|
|
|
end function psb_c_cd_get_global_rows
|
|
|
|
|
|
|
|
function psb_c_cd_get_global_cols(cdh) bind(c,name='psb_c_cd_get_global_cols') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_lpk_) :: res
|
|
type(psb_c_object_type) :: cdh
|
|
|
|
type(psb_desc_type), pointer :: descp
|
|
integer :: info
|
|
|
|
res = -1
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
res = descp%get_global_cols()
|
|
|
|
end if
|
|
|
|
end function psb_c_cd_get_global_cols
|
|
|
|
function psb_c_cd_get_global_indices(idx,nidx,owned,cdh) &
|
|
& bind(c,name='psb_c_cd_get_global_indices') result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
type(psb_c_object_type) :: cdh
|
|
|
|
integer(psb_c_lpk_) :: idx(nidx)
|
|
integer(psb_c_ipk_), value :: nidx
|
|
logical(c_bool), value :: owned
|
|
|
|
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_lpk_), allocatable :: myidx(:)
|
|
integer(psb_c_ipk_) :: ixb
|
|
logical :: fowned
|
|
res = -1
|
|
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
|
|
fowned = owned
|
|
myidx = descp%get_global_indices(owned=fowned)
|
|
ixb = psb_c_get_index_base()
|
|
idx(1:nidx) = myidx(1:nidx) - (1-ixb)
|
|
res = 0
|
|
|
|
end if
|
|
|
|
end function psb_c_cd_get_global_indices
|
|
|
|
function psb_c_is_owned(x,cdh) bind(c,name='psb_c_is_owned') result(res)
|
|
implicit none
|
|
type(psb_c_object_type) :: cdh
|
|
integer(psb_c_lpk_), value :: x
|
|
logical(c_bool) :: res
|
|
! Internal variables
|
|
type(psb_desc_type), pointer :: descp
|
|
integer(psb_c_ipk_) :: info
|
|
logical :: fowned
|
|
res = .false.
|
|
if (c_associated(cdh%item)) then
|
|
call c_f_pointer(cdh%item,descp)
|
|
fowned = psb_is_owned(x+(1-psb_c_get_index_base()),descp)
|
|
if (fowned) then
|
|
res = .true.
|
|
end if
|
|
end if
|
|
|
|
end function psb_c_is_owned
|
|
|
|
|
|
end module psb_base_tools_cbind_mod
|