mirror of
https://github.com/sfilippone/psblas3.git
synced 2026-10-16 19:02:09 +00:00
Added routine to get integer context for c-mpi interoperability
This commit is contained in:
Cirdans-Home
@@ -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
|
||||
|
||||
@@ -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();
|
||||
|
||||
|
||||
+106
-91
@@ -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_)
|
||||
|
||||
Reference in New Issue
Block a user