diff --git a/base/modules/psb_const_mod.F90 b/base/modules/psb_const_mod.F90 index dee01457..5f13edaf 100644 --- a/base/modules/psb_const_mod.F90 +++ b/base/modules/psb_const_mod.F90 @@ -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 diff --git a/cbind/base/psb_c_base.h b/cbind/base/psb_c_base.h index bc4eb021..df97c50b 100644 --- a/cbind/base/psb_c_base.h +++ b/cbind/base/psb_c_base.h @@ -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(); diff --git a/cbind/base/psb_cpenv_mod.f90 b/cbind/base/psb_cpenv_mod.f90 index a4d588c2..b6a6a3d2 100644 --- a/cbind/base/psb_cpenv_mod.f90 +++ b/cbind/base/psb_cpenv_mod.f90 @@ -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_)