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.
468 lines
12 KiB
Fortran
468 lines
12 KiB
Fortran
module psb_cpenv_mod
|
|
use iso_c_binding
|
|
use psb_base_mod
|
|
use psb_objhandle_mod
|
|
|
|
integer, private :: psb_c_index_base=0
|
|
|
|
contains
|
|
|
|
function psb_c_get_index_base() bind(c) result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
|
|
res = psb_c_index_base
|
|
end function psb_c_get_index_base
|
|
|
|
subroutine psb_c_set_index_base(base) bind(c)
|
|
implicit none
|
|
integer(psb_c_ipk_), value :: base
|
|
|
|
psb_c_index_base = base
|
|
end subroutine psb_c_set_index_base
|
|
|
|
function psb_c_get_errstatus() bind(c) result(res)
|
|
implicit none
|
|
|
|
integer(psb_c_ipk_) :: res
|
|
|
|
res = psb_get_errstatus()
|
|
end function psb_c_get_errstatus
|
|
|
|
subroutine psb_c_init(cctxt) bind(c)
|
|
implicit none
|
|
|
|
type(psb_c_object_type) :: cctxt
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer :: info
|
|
|
|
if (c_associated(cctxt%item)) then
|
|
call c_f_pointer(cctxt%item,ctxt)
|
|
deallocate(ctxt,stat=info)
|
|
if (info /= 0) return
|
|
end if
|
|
allocate(ctxt,stat=info)
|
|
if (info /= 0) return
|
|
call psb_init(ctxt)
|
|
cctxt%item = c_loc(ctxt)
|
|
|
|
end subroutine psb_c_init
|
|
|
|
#ifdef PSB_HAVE_CUDA
|
|
subroutine psb_c_cuda_init(cctxt) bind(c, name="psb_c_cuda_init")
|
|
use psb_cuda_mod, only : psb_cuda_init
|
|
implicit none
|
|
|
|
type(psb_c_object_type) :: cctxt
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer :: info
|
|
|
|
if (c_associated(cctxt%item)) then
|
|
call c_f_pointer(cctxt%item,ctxt)
|
|
end if
|
|
call psb_cuda_init(ctxt)
|
|
cctxt%item = c_loc(ctxt)
|
|
end subroutine psb_c_cuda_init
|
|
|
|
subroutine psb_c_cuda_init_opt(cctxt,cdevice) bind(c, name="psb_c_cuda_init_opt")
|
|
use psb_cuda_mod, only : psb_cuda_init
|
|
implicit none
|
|
|
|
type(psb_c_object_type) :: cctxt
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer(psb_c_mpk_), value :: cdevice
|
|
integer :: info
|
|
! Local variables
|
|
integer(psb_mpk_) :: cdevice_f
|
|
|
|
cdevice_f = cdevice
|
|
|
|
if (c_associated(cctxt%item)) then
|
|
call c_f_pointer(cctxt%item,ctxt)
|
|
end if
|
|
call psb_cuda_init(ctxt,cdevice_f)
|
|
cctxt%item = c_loc(ctxt)
|
|
|
|
end subroutine psb_c_cuda_init_opt
|
|
|
|
subroutine psb_c_cuda_exit() bind(c, name="psb_c_cuda_exit")
|
|
use psb_cuda_mod, only : psb_cuda_exit
|
|
implicit none
|
|
|
|
call psb_cuda_exit()
|
|
return
|
|
end subroutine psb_c_cuda_exit
|
|
|
|
function psb_c_cuda_getDeviceCount() bind(c, name="psb_c_cuda_getDeviceCount") result(res)
|
|
use psb_cuda_mod, only : psb_cuda_getDeviceCount
|
|
implicit none
|
|
integer(psb_c_ipk_) :: res
|
|
! Local variables
|
|
integer(psb_ipk_) :: fres
|
|
|
|
fres = psb_cuda_getDeviceCount()
|
|
res = fres
|
|
|
|
return
|
|
end function psb_c_cuda_getDeviceCount
|
|
#endif
|
|
|
|
! Get MPI_Fint from C, psb_c_object_type and start a psb_ctxt_type
|
|
! context from it.
|
|
subroutine psb_c_init_from_fint(cctxt,fint) bind(c)
|
|
implicit none
|
|
|
|
type(psb_c_object_type) :: cctxt
|
|
integer(psb_c_mpk_), value :: fint
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer :: info
|
|
|
|
! Local variables
|
|
integer(psb_mpk_) :: fmctxt
|
|
|
|
allocate(ctxt,stat=info)
|
|
if (info /= 0) return
|
|
fmctxt = fint
|
|
call psb_init(ctxt,extcomm=fmctxt)
|
|
cctxt%item = c_loc(ctxt)
|
|
|
|
end subroutine psb_c_init_from_fint
|
|
|
|
function psb_c2f_ctxt(cctxt) result(res)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
type(psb_ctxt_type), pointer :: res
|
|
|
|
!res%ctxt = cctxt%ctxt
|
|
if (.not.c_associated(cctxt%item)) then
|
|
write(0,*) 'Null item in c2f_ctxt? '
|
|
flush(0)
|
|
end if
|
|
if (c_associated(cctxt%item)) call c_f_pointer(cctxt%item,res)
|
|
end function psb_c2f_ctxt
|
|
|
|
subroutine psb_c_get_i_ctxt(cctxt,ictxt,info) bind(c)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_) :: ictxt
|
|
integer(psb_c_ipk_) :: info
|
|
|
|
! Local variables
|
|
integer(psb_c_mpk_) :: mctxt
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
|
|
call ctxt%get_i_ctxt(mctxt,info)
|
|
ictxt = mctxt
|
|
end subroutine
|
|
|
|
function psb_c_cmp_ctxt(cctxt1, cctxt2) bind(c,name="psb_c_cmp_ctxt") result(res)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt1, cctxt2
|
|
logical(c_bool) :: res
|
|
|
|
logical :: equal
|
|
type(psb_ctxt_type), pointer :: ctxt1, ctxt2
|
|
|
|
ctxt1 => psb_c2f_ctxt(cctxt1)
|
|
ctxt2 => psb_c2f_ctxt(cctxt2)
|
|
|
|
equal = psb_cmp_ctxt(ctxt1, ctxt2)
|
|
|
|
res = equal
|
|
|
|
end function
|
|
|
|
subroutine psb_c_exit_ctxt(cctxt) bind(c)
|
|
type(psb_c_object_type), value :: cctxt
|
|
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
call psb_exit(ctxt,close=.false.)
|
|
|
|
deallocate(ctxt,stat=info)
|
|
|
|
return
|
|
end subroutine psb_c_exit_ctxt
|
|
|
|
subroutine psb_c_exit(cctxt) bind(c)
|
|
type(psb_c_object_type), value :: cctxt
|
|
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer(psb_ipk_) :: info
|
|
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
call psb_exit(ctxt)
|
|
deallocate(ctxt,stat=info)
|
|
cctxt%item = c_null_ptr
|
|
return
|
|
end subroutine psb_c_exit
|
|
|
|
subroutine psb_c_abort(cctxt) bind(c)
|
|
type(psb_c_object_type), value :: cctxt
|
|
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
call psb_abort(ctxt)
|
|
return
|
|
end subroutine psb_c_abort
|
|
|
|
subroutine psb_c_check_error(cctxt) bind(c)
|
|
implicit none
|
|
|
|
type(psb_c_object_type), value :: cctxt
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer :: info
|
|
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
call psb_check_error(ctxt,abrt=.true.)
|
|
|
|
end subroutine psb_c_check_error
|
|
|
|
subroutine psb_c_info(cctxt,iam,np) bind(c)
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_) :: iam,np
|
|
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
call psb_info(ctxt,iam,np)
|
|
return
|
|
end subroutine psb_c_info
|
|
|
|
subroutine psb_c_barrier(cctxt) bind(c)
|
|
type(psb_c_object_type), value :: cctxt
|
|
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
call psb_barrier(ctxt)
|
|
end subroutine psb_c_barrier
|
|
|
|
real(c_double) function psb_c_wtime() bind(c)
|
|
|
|
psb_c_wtime = psb_wtime()
|
|
end function psb_c_wtime
|
|
|
|
subroutine psb_c_mbcast(cctxt,n,v,root) bind(c)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: n, root
|
|
integer(psb_c_mpk_) :: v(*)
|
|
integer(psb_c_mpk_) :: mroot
|
|
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
|
|
if (n < 0) then
|
|
write(0,*) 'Wrong size in BCAST'
|
|
return
|
|
end if
|
|
if (n==0) return
|
|
mroot=root
|
|
|
|
call psb_bcast(ctxt,v(1:n),root=mroot)
|
|
end subroutine psb_c_mbcast
|
|
|
|
subroutine psb_c_ibcast(cctxt,n,v,root) bind(c)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: n, root
|
|
integer(psb_c_ipk_) :: v(*)
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer(psb_c_mpk_) :: mroot
|
|
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
|
|
if (n < 0) then
|
|
write(0,*) 'Wrong size in BCAST'
|
|
return
|
|
end if
|
|
if (n==0) return
|
|
mroot=root
|
|
|
|
call psb_bcast(ctxt,v(1:n),root=mroot)
|
|
end subroutine psb_c_ibcast
|
|
|
|
subroutine psb_c_lbcast(cctxt,n,v,root) bind(c)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: n, root
|
|
integer(psb_c_lpk_) :: v(*)
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer(psb_c_mpk_) :: mroot
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
|
|
if (n < 0) then
|
|
write(0,*) 'Wrong size in BCAST'
|
|
return
|
|
end if
|
|
if (n==0) return
|
|
mroot=root
|
|
|
|
call psb_bcast(ctxt,v(1:n),root=mroot)
|
|
end subroutine psb_c_lbcast
|
|
|
|
subroutine psb_c_ebcast(cctxt,n,v,root) bind(c)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: n, root
|
|
integer(psb_c_epk_) :: v(*)
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer(psb_c_mpk_) :: mroot
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
|
|
if (n < 0) then
|
|
write(0,*) 'Wrong size in BCAST'
|
|
return
|
|
end if
|
|
if (n==0) return
|
|
mroot=root
|
|
|
|
call psb_bcast(ctxt,v(1:n),root=mroot)
|
|
end subroutine psb_c_ebcast
|
|
|
|
subroutine psb_c_sbcast(cctxt,n,v,root) bind(c)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: n, root
|
|
real(c_float) :: v(*)
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer(psb_c_mpk_) :: mroot
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
|
|
if (n < 0) then
|
|
write(0,*) 'Wrong size in BCAST'
|
|
return
|
|
end if
|
|
if (n==0) return
|
|
mroot=root
|
|
|
|
call psb_bcast(ctxt,v(1:n),root=mroot)
|
|
end subroutine psb_c_sbcast
|
|
|
|
subroutine psb_c_dbcast(cctxt,n,v,root) bind(c)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: n, root
|
|
real(c_double) :: v(*)
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer(psb_c_mpk_) :: mroot
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
|
|
if (n < 0) then
|
|
write(0,*) 'Wrong size in BCAST'
|
|
return
|
|
end if
|
|
if (n==0) return
|
|
mroot=root
|
|
|
|
call psb_bcast(ctxt,v(1:n),root=mroot)
|
|
end subroutine psb_c_dbcast
|
|
|
|
|
|
subroutine psb_c_cbcast(cctxt,n,v,root) bind(c)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: n, root
|
|
complex(c_float_complex) :: v(*)
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer(psb_c_mpk_) :: mroot
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
|
|
if (n < 0) then
|
|
write(0,*) 'Wrong size in BCAST'
|
|
return
|
|
end if
|
|
if (n==0) return
|
|
mroot=root
|
|
|
|
call psb_bcast(ctxt,v(1:n),root=mroot)
|
|
end subroutine psb_c_cbcast
|
|
|
|
subroutine psb_c_zbcast(cctxt,n,v,root) bind(c)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: n, root
|
|
complex(c_double_complex) :: v(*)
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer(psb_c_mpk_) :: mroot
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
|
|
if (n < 0) then
|
|
write(0,*) 'Wrong size in BCAST'
|
|
return
|
|
end if
|
|
if (n==0) return
|
|
mroot=root
|
|
|
|
call psb_bcast(ctxt,v(1:n),root=mroot)
|
|
end subroutine psb_c_zbcast
|
|
|
|
subroutine psb_c_hbcast(cctxt,v,root) bind(c)
|
|
implicit none
|
|
type(psb_c_object_type), value :: cctxt
|
|
integer(psb_c_ipk_), value :: root
|
|
character(c_char) :: v(*)
|
|
integer(psb_ipk_) :: iam, np, n
|
|
type(psb_ctxt_type), pointer :: ctxt
|
|
integer(psb_c_mpk_) :: mroot
|
|
ctxt => psb_c2f_ctxt(cctxt)
|
|
|
|
call psb_info(ctxt,iam,np)
|
|
|
|
if (iam==root) then
|
|
n = 1
|
|
do
|
|
if (v(n) == c_null_char) exit
|
|
n = n + 1
|
|
end do
|
|
end if
|
|
mroot=root
|
|
call psb_bcast(ctxt,n,root=mroot)
|
|
call psb_bcast(ctxt,v(1:n),root=mroot)
|
|
end subroutine psb_c_hbcast
|
|
|
|
function psb_c_f2c_errmsg(cmesg,len) bind(c) result(res)
|
|
use psb_string_mod
|
|
implicit none
|
|
character(c_char), intent(inout) :: cmesg(*)
|
|
integer(psb_c_ipk_), intent(in), value :: len
|
|
integer(psb_c_ipk_) :: res
|
|
character(len=psb_max_errmsg_len_), allocatable :: fmesg(:)
|
|
character(len=psb_max_errmsg_len_) :: tmp
|
|
integer :: i, j, ll, il
|
|
|
|
res = 0
|
|
call psb_errpop(fmesg)
|
|
ll = 1
|
|
if (allocated(fmesg)) then
|
|
res = size(fmesg)
|
|
do i=1, size(fmesg)
|
|
tmp = fmesg(i)
|
|
il = len_trim(tmp)
|
|
il = min(il,len-ll)
|
|
!write(0,*) 'loop f2c_errmsg: ', ll,il
|
|
call psb_stringf2c(tmp(1:il),cmesg(ll:ll+il))
|
|
cmesg(ll+il)=c_new_line
|
|
ll = ll+il+1
|
|
end do
|
|
!write(0,*) 'From f2c_errmsg: ', ll,len
|
|
end if
|
|
cmesg(ll) = c_null_char
|
|
end function psb_c_f2c_errmsg
|
|
|
|
subroutine psb_c_seterraction_ret() bind(c)
|
|
call psb_set_erraction(psb_act_ret_)
|
|
end subroutine psb_c_seterraction_ret
|
|
|
|
subroutine psb_c_seterraction_print() bind(c)
|
|
call psb_set_erraction(psb_act_print_)
|
|
end subroutine psb_c_seterraction_print
|
|
|
|
subroutine psb_c_seterraction_abort() bind(c)
|
|
call psb_set_erraction(psb_act_abort_)
|
|
end subroutine psb_c_seterraction_abort
|
|
|
|
end module psb_cpenv_mod
|