Added routine to get integer context for c-mpi interoperability

base/modules/psb_const_mod.F90

@@ -1,9 +1,9 @@
-!   
+!
 !                Parallel Sparse BLAS  version 3.5
 !      (C) Copyright 2006-2018
-!        Salvatore Filippone    
+!        Salvatore Filippone
-!        Alfredo Buttari      
+!        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_unsorted_  = 0
-  integer(psb_ipk_), parameter :: psb_row_major_ = 1 
+  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) 
+#if defined(HAVE_ISO_FORTRAN_ENV)
-  integer(psb_ipk_), save :: psb_err_unit = error_unit  
+  integer(psb_ipk_), save :: psb_err_unit = error_unit
-  integer(psb_ipk_), save :: psb_inp_unit = input_unit  
+  integer(psb_ipk_), save :: psb_inp_unit = input_unit
-  integer(psb_ipk_), save :: psb_out_unit = output_unit 
+  integer(psb_ipk_), save :: psb_out_unit = output_unit
-#else 
+#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

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();
 

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) 
+  subroutine psb_c_set_index_base(base) bind(c)
-    implicit none     
+    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 
+    if (iam==root) then
-      n = 1 
+      n = 1
-      do 
+      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 
+    if (allocated(fmesg)) then
-      res = size(fmesg) 
+      res = size(fmesg)
       do i=1, size(fmesg)
         tmp = fmesg(i)
         il = len_trim(tmp)
-        il = min(il,len-ll)      
+        il = min(il,len-ll)
-        !write(0,*) 'loop f2c_errmsg: ', ll,il          
+        !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_)