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

Added routine to get integer context for c-mpi interoperability

Browse Source
newG2L
Cirdans-Home 4 years ago
parent 321814d247
commit e64d52cbc2
3 changed files with 153 additions and 120 deletions
Show Stats Download Patch File Download Diff File

75
base/modules/psb_const_mod.F90
Unescape Escape View File

@ -1,9 +1,9 @@
!
!
! Parallel Sparse BLAS version 3.5
! (C) Copyright 2006-2018
! Salvatore Filippone
! Alfredo Buttari
!
! Salvatore Filippone
! Alfredo Buttari
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions
! are met:
@ -15,7 +15,7 @@
! 3. The name of the PSBLAS group or the names of its contributors may
! not be used to endorse or promote products derived from this
! software without specific written permission.
!
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
! ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
@ -27,8 +27,8 @@
! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
! POSSIBILITY OF SUCH DAMAGE.
!
!
!
!
module psb_const_mod
#if defined(HAVE_ISO_FORTRAN_ENV)
@ -45,9 +45,9 @@ module psb_const_mod
!
integer, parameter :: psb_spk_ = real32
integer, parameter :: psb_dpk_ = real64
#else
! This is a 2-byte integer, just in case
integer, parameter :: i2ndig=4
integer, parameter :: psb_i2pk_ = selected_int_kind(i2ndig)
@ -84,7 +84,7 @@ module psb_const_mod
! 4. For the array version of things, where it makes sense
! e.g. realloc, snd/receive, define as MPK,EPK and the
! compiler will later pick up the correct version according
! to what IPK/LPK are mapped onto.
! to what IPK/LPK are mapped onto.
!
#if defined(IPK4) && defined(LPK4)
integer, parameter :: psb_ipk_ = psb_mpk_
@ -99,8 +99,8 @@ module psb_const_mod
! Unsupported combination, compilation will stop later on
integer, parameter :: psb_ipk_ = -1
integer, parameter :: psb_lpk_ = -1
#endif
#endif
integer(psb_ipk_), save :: psb_sizeof_sp
integer(psb_ipk_), save :: psb_sizeof_dp
integer(psb_ipk_), save :: psb_sizeof_i2p = 2
@ -122,7 +122,7 @@ module psb_const_mod
#endif
!
! Integer type identifiers for MPI operations.
! Integer type identifiers for MPI operations.
!
integer(psb_mpk_), save :: psb_mpi_i2pk_
integer(psb_mpk_), save :: psb_mpi_epk_
@ -133,7 +133,7 @@ module psb_const_mod
integer(psb_mpk_), save :: psb_mpi_r_dpk_
integer(psb_mpk_), save :: psb_mpi_c_spk_
integer(psb_mpk_), save :: psb_mpi_c_dpk_
!
!
! Version
!
character(len=*), parameter :: psb_version_string_ = "3.7.0"
@ -162,7 +162,7 @@ module psb_const_mod
complex(psb_spk_), parameter :: cone=(1.0_psb_spk_,0.0_psb_spk_)
complex(psb_dpk_), parameter :: zzero=(0.0_psb_dpk_,0.0_psb_dpk_)
complex(psb_dpk_), parameter :: zone=(1.0_psb_dpk_,0.0_psb_dpk_)
real(psb_dpk_), parameter :: d_epstol=1.1e-16_psb_dpk_ ! Unit roundoff.
real(psb_dpk_), parameter :: d_epstol=1.1e-16_psb_dpk_ ! Unit roundoff.
real(psb_spk_), parameter :: s_epstol=5.e-8_psb_spk_ ! Is this right?
character, parameter :: psb_all_='A', psb_topdef_=' '
logical, parameter :: psb_m_is_complex_ = .false.
@ -181,8 +181,8 @@ module psb_const_mod
!
! Sort routines constants
!
!
! The up/down constant are defined in pairs having
!
! The up/down constant are defined in pairs having
! opposite values. We make use of this fact in the heapsort routine.
!
integer(psb_ipk_), parameter :: psb_sort_up_ = 1, psb_sort_down_ = -1
@ -200,7 +200,7 @@ module psb_const_mod
!
! State of matrices.
!
integer(psb_ipk_), parameter :: psb_invalid_ = -1
integer(psb_ipk_), parameter :: psb_invalid_ = -1
integer(psb_ipk_), parameter :: psb_spmat_null_=0, psb_spmat_bld_=1
integer(psb_ipk_), parameter :: psb_spmat_asb_=2, psb_spmat_upd_=4
@ -208,10 +208,10 @@ module psb_const_mod
integer(psb_ipk_), parameter :: psb_iflag_=2, psb_ichk_=3
integer(psb_ipk_), parameter :: psb_nnzt_=4, psb_zero_=5,psb_ipc_=6
integer(psb_ipk_), parameter :: psb_unsorted_ = 0
integer(psb_ipk_), parameter :: psb_row_major_ = 1
integer(psb_ipk_), parameter :: psb_unsorted_ = 0
integer(psb_ipk_), parameter :: psb_row_major_ = 1
integer(psb_ipk_), parameter :: psb_col_major_ = 2
! Duplicate coefficients handling
! These are usually set while calling spcnv as one of its
! optional arugments.
@ -224,18 +224,18 @@ module psb_const_mod
integer(psb_ipk_), parameter :: psb_upd_perm_ = 98765
integer(psb_ipk_), parameter :: psb_upd_dflt_ = psb_upd_srch_
#if defined(HAVE_ISO_FORTRAN_ENV)
integer(psb_ipk_), save :: psb_err_unit = error_unit
integer(psb_ipk_), save :: psb_inp_unit = input_unit
integer(psb_ipk_), save :: psb_out_unit = output_unit
#else
#if defined(HAVE_ISO_FORTRAN_ENV)
integer(psb_ipk_), save :: psb_err_unit = error_unit
integer(psb_ipk_), save :: psb_inp_unit = input_unit
integer(psb_ipk_), save :: psb_out_unit = output_unit
#else
integer(psb_ipk_), save :: psb_err_unit = 0
integer(psb_ipk_), save :: psb_inp_unit = 5
integer(psb_ipk_), save :: psb_out_unit = 6
#endif
!
!
!
! Error constants
integer(psb_ipk_), parameter, public :: psb_success_=0
integer(psb_ipk_), parameter, public :: psb_err_pivot_too_small_=2
@ -316,8 +316,10 @@ module psb_const_mod
integer(psb_ipk_), parameter, public :: psb_err_invalid_preca_=5004
type psb_ctxt_type
type :: psb_ctxt_type
integer(psb_mpk_), allocatable :: ctxt
contains
procedure, pass(ctxt) :: get_i_ctxt => psb_get_i_ctxt
end type psb_ctxt_type
contains
@ -334,4 +336,19 @@ contains
end function psb_cmp_ctxt
subroutine psb_get_i_ctxt(ctxt,ictxt,info)
class(psb_ctxt_type), intent(in) :: ctxt
integer(psb_mpk_), intent(out) :: ictxt
integer(psb_ipk_), intent(out) :: info
if (.not.allocated(ctxt%ctxt)) then
ictxt = -1_psb_ipk_
info = psb_err_mpi_error_
else
ictxt = ctxt%ctxt
info = psb_success_
end if
end subroutine psb_get_i_ctxt
end module psb_const_mod

1
cbind/base/psb_c_base.h
Unescape Escape View File

@ -65,6 +65,7 @@ extern "C" {
void psb_c_abort(psb_c_ctxt cctxt);
void psb_c_barrier(psb_c_ctxt cctxt);
void psb_c_info(psb_c_ctxt cctxt, psb_i_t *iam, psb_i_t *np);
void psb_c_get_i_ctxt(psb_c_ctxt cctxt, psb_i_t *ictxt, psb_i_t *info);
psb_d_t psb_c_wtime();
psb_i_t psb_c_get_errstatus();

197
cbind/base/psb_cpenv_mod.f90
Unescape Escape View File

@ -3,37 +3,37 @@ module psb_cpenv_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
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
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
end subroutine psb_c_set_index_base
function psb_c_get_errstatus() bind(c) result(res)
use psb_base_mod, only : psb_get_errstatus, psb_ctxt_type
implicit none
implicit none
integer(psb_c_ipk_) :: res
res = psb_get_errstatus()
end function psb_c_get_errstatus
subroutine psb_c_init(cctxt) bind(c)
subroutine psb_c_init(cctxt) bind(c)
use psb_base_mod, only : psb_init, psb_ctxt_type
implicit none
implicit none
type(psb_c_object_type) :: cctxt
type(psb_ctxt_type), pointer :: ctxt
integer :: info
@ -44,14 +44,14 @@ contains
if (info /= 0) return
end if
allocate(ctxt,stat=info)
if (info /= 0) return
if (info /= 0) return
call psb_init(ctxt)
cctxt%item = c_loc(ctxt)
end subroutine psb_c_init
function psb_c2f_ctxt(cctxt) result(res)
implicit none
implicit none
type(psb_c_object_type), value :: cctxt
type(psb_ctxt_type), pointer :: res
@ -62,50 +62,65 @@ contains
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
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
call ctxt%get_i_ctxt(ictxt,info)
end subroutine
subroutine psb_c_exit_ctxt(cctxt) bind(c)
use psb_base_mod, only : psb_exit, psb_ctxt_type
type(psb_c_object_type), value :: cctxt
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
call psb_exit(ctxt,close=.false.)
return
end subroutine psb_c_exit_ctxt
subroutine psb_c_exit(cctxt) bind(c)
use psb_base_mod, only : psb_exit, psb_ctxt_type
type(psb_c_object_type), value :: cctxt
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
call psb_exit(ctxt)
return
end subroutine psb_c_exit
subroutine psb_c_abort(cctxt) bind(c)
use psb_base_mod, only : psb_abort, psb_ctxt_type
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_info(cctxt,iam,np) bind(c)
use psb_base_mod, only : psb_info, psb_ctxt_type
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)
use psb_base_mod, only : psb_barrier, psb_ctxt_type
type(psb_c_object_type), value :: cctxt
@ -114,175 +129,175 @@ contains
ctxt => psb_c2f_ctxt(cctxt)
call psb_barrier(ctxt)
end subroutine psb_c_barrier
real(c_double) function psb_c_wtime() bind(c)
use psb_base_mod, only : psb_wtime, psb_ctxt_type
psb_c_wtime = psb_wtime()
end function psb_c_wtime
subroutine psb_c_mbcast(cctxt,n,v,root) bind(c)
use psb_base_mod, only : psb_bcast, psb_ctxt_type
implicit none
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_) :: v(*)
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
if (n < 0) then
if (n < 0) then
write(0,*) 'Wrong size in BCAST'
return
end if
if (n==0) return
if (n==0) return
call psb_bcast(ctxt,v(1:n),root=root)
end subroutine psb_c_mbcast
subroutine psb_c_ibcast(cctxt,n,v,root) bind(c)
use psb_base_mod, only : psb_bcast, psb_ctxt_type
implicit none
implicit none
type(psb_c_object_type), value :: cctxt
integer(psb_c_ipk_), value :: n, root
integer(psb_c_ipk_) :: v(*)
integer(psb_c_ipk_) :: v(*)
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
if (n < 0) then
if (n < 0) then
write(0,*) 'Wrong size in BCAST'
return
end if
if (n==0) return
if (n==0) return
call psb_bcast(ctxt,v(1:n),root=root)
end subroutine psb_c_ibcast
subroutine psb_c_lbcast(cctxt,n,v,root) bind(c)
use psb_base_mod, only : psb_bcast, psb_ctxt_type
implicit none
implicit none
type(psb_c_object_type), value :: cctxt
integer(psb_c_ipk_), value :: n, root
integer(psb_c_lpk_) :: v(*)
integer(psb_c_lpk_) :: v(*)
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
if (n < 0) then
if (n < 0) then
write(0,*) 'Wrong size in BCAST'
return
end if
if (n==0) return
if (n==0) return
call psb_bcast(ctxt,v(1:n),root=root)
end subroutine psb_c_lbcast
subroutine psb_c_ebcast(cctxt,n,v,root) bind(c)
use psb_base_mod, only : psb_bcast, psb_ctxt_type
implicit none
implicit none
type(psb_c_object_type), value :: cctxt
integer(psb_c_ipk_), value :: n, root
integer(psb_c_epk_) :: v(*)
integer(psb_c_epk_) :: v(*)
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
if (n < 0) then
if (n < 0) then
write(0,*) 'Wrong size in BCAST'
return
end if
if (n==0) return
if (n==0) return
call psb_bcast(ctxt,v(1:n),root=root)
end subroutine psb_c_ebcast
subroutine psb_c_sbcast(cctxt,n,v,root) bind(c)
use psb_base_mod
implicit none
implicit none
type(psb_c_object_type), value :: cctxt
integer(psb_c_ipk_), value :: n, root
real(c_float) :: v(*)
real(c_float) :: v(*)
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
if (n < 0) then
if (n < 0) then
write(0,*) 'Wrong size in BCAST'
return
end if
if (n==0) return
if (n==0) return
call psb_bcast(ctxt,v(1:n),root=root)
end subroutine psb_c_sbcast
subroutine psb_c_dbcast(cctxt,n,v,root) bind(c)
use psb_base_mod, only : psb_bcast, psb_ctxt_type
implicit none
implicit none
type(psb_c_object_type), value :: cctxt
integer(psb_c_ipk_), value :: n, root
real(c_double) :: v(*)
real(c_double) :: v(*)
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
if (n < 0) then
if (n < 0) then
write(0,*) 'Wrong size in BCAST'
return
end if
if (n==0) return
if (n==0) return
call psb_bcast(ctxt,v(1:n),root=root)
end subroutine psb_c_dbcast
subroutine psb_c_cbcast(cctxt,n,v,root) bind(c)
use psb_base_mod, only : psb_bcast, psb_ctxt_type
implicit none
implicit none
type(psb_c_object_type), value :: cctxt
integer(psb_c_ipk_), value :: n, root
complex(c_float_complex) :: v(*)
complex(c_float_complex) :: v(*)
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
if (n < 0) then
if (n < 0) then
write(0,*) 'Wrong size in BCAST'
return
end if
if (n==0) return
if (n==0) return
call psb_bcast(ctxt,v(1:n),root=root)
end subroutine psb_c_cbcast
subroutine psb_c_zbcast(cctxt,n,v,root) bind(c)
use psb_base_mod
implicit none
implicit none
type(psb_c_object_type), value :: cctxt
integer(psb_c_ipk_), value :: n, root
complex(c_double_complex) :: v(*)
complex(c_double_complex) :: v(*)
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
if (n < 0) then
if (n < 0) then
write(0,*) 'Wrong size in BCAST'
return
end if
if (n==0) return
if (n==0) return
call psb_bcast(ctxt,v(1:n),root=root)
end subroutine psb_c_zbcast
subroutine psb_c_hbcast(cctxt,v,root) bind(c)
use psb_base_mod, only : psb_bcast, psb_info, psb_ipk_, psb_ctxt_type
implicit none
implicit none
type(psb_c_object_type), value :: cctxt
integer(psb_c_ipk_), value :: root
character(c_char) :: v(*)
character(c_char) :: v(*)
integer(psb_ipk_) :: iam, np, n
type(psb_ctxt_type), pointer :: ctxt
ctxt => psb_c2f_ctxt(cctxt)
call psb_info(ctxt,iam,np)
if (iam==root) then
n = 1
do
if (iam==root) then
n = 1
do
if (v(n) == c_null_char) exit
n = n + 1
end do
@ -294,7 +309,7 @@ contains
function psb_c_f2c_errmsg(cmesg,len) bind(c) result(res)
use psb_base_mod, only : psb_errpop,psb_max_errmsg_len_, psb_ctxt_type
use psb_base_string_cbind_mod
implicit none
implicit none
character(c_char), intent(inout) :: cmesg(*)
integer(psb_c_ipk_), intent(in), value :: len
integer(psb_c_ipk_) :: res
@ -305,13 +320,13 @@ contains
res = 0
call psb_errpop(fmesg)
ll = 1
if (allocated(fmesg)) then
res = size(fmesg)
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
il = min(il,len-ll)
!write(0,*) 'loop f2c_errmsg: ', ll,il
call stringf2c(tmp(1:il),cmesg(ll:ll+il))
cmesg(ll+il)=c_new_line
ll = ll+il+1
@ -320,7 +335,7 @@ contains
end if
cmesg(ll) = c_null_char
end function psb_c_f2c_errmsg
subroutine psb_c_seterraction_ret() bind(c)
use psb_base_mod, only : psb_set_erraction, psb_act_ret_, psb_ctxt_type
call psb_set_erraction(psb_act_ret_)

Write Preview
Loading…
Cancel
Save