Introduced routines for MPI shared memory

MPI shared memory is a concept for allocating memory accessibly by ranks
that are connected to the same physical memory, i.e. on the same node in
a cluster. In this basic implementation here, we can use this concept to
reduce the memory usage of an application if large arrays are stored
only once per node and not once per MPI task.

See test/test_shared_memory.f90 for a short example.

lib/CMakeLists.txt

@@ -19,7 +19,8 @@ set(sources-fpp
   mpifx_reduce.fpp
   mpifx_scatter.fpp
   mpifx_scatterv.fpp
-  mpifx_send.fpp)
+  mpifx_send.fpp
+  mpifx_shared_memory.fpp)
 
 fypp_preprocess("${sources-fpp}" sources-f90)
 

lib/module.fpp

@@ -30,6 +30,7 @@ module libmpifx_module
   use mpifx_allgatherv_module
   use mpifx_scatter_module
   use mpifx_scatterv_module
+  use mpifx_shared_memory_module
   implicit none
   public
 

lib/mpifx_shared_memory.fpp

@@ -0,0 +1,150 @@
+#:include 'mpifx.fypp'
+#:set TYPES = NUMERIC_TYPES
+
+!> Contains utilities for handling MPI shared memory
+module mpifx_shared_memory_module
+  use mpifx_common_module
+  use iso_c_binding, only : c_ptr, c_f_pointer
+  implicit none
+  private
+
+  public :: mpifx_allocate_shared, mpifx_free_shared, mpifx_lock_shared, mpifx_unlock_shared, mpifx_sync_shared
+
+  interface mpifx_allocate_shared
+#:for TYPE in TYPES
+  #:set TYPEABBREV = TYPE_ABBREVS[TYPE]
+  module procedure mpifx_allocate_shared_${TYPEABBREV}$
+#:endfor
+  end interface mpifx_allocate_shared
+
+contains
+
+#:def mpifx_allocate_shared_template(SUFFIX, TYPE)
+
+  !> Returns a window handle and a pointer to the address associated with a shared memory segment.
+  !!
+  !! \param mycomm  MPI communicator.
+  !! \param length  Number of elements of type ${TYPE}$ in the shared memory window.
+  !! \param win  Handle of the shared memory window on return.
+  !! \param shared_data  Pointer to the shared data array of length 'length' on return.
+  !! \param error  Optional error code on return.
+  !!
+  !! \see MPI documentation (\c MPI_WIN_ALLOCATE_SHARED)
+  !!
+  subroutine mpifx_allocate_shared_${SUFFIX}$(mycomm, length, win, shared_data, error)
+    type(mpifx_comm), intent(in) :: mycomm
+    integer, intent(in) :: length
+    integer, intent(out) :: win
+    ${TYPE}$, pointer, intent(out) :: shared_data(:)
+    integer, intent(out), optional :: error
+
+    integer :: disp_unit, error0, error1
+    integer(MPI_ADDRESS_KIND) :: local_length
+    type(c_ptr) :: baseptr
+
+    disp_unit = kind(shared_data)
+
+    local_length = 0
+    if (mycomm%lead) then
+      local_length = length * disp_unit
+    end if
+
+    call mpi_win_allocate_shared(local_length, disp_unit, MPI_INFO_NULL, mycomm%id, baseptr, win, error0)
+    call handle_errorflag(error0, "MPI_WIN_ALLOCATE_SHARED in mpifx_allocate_shared_${SUFFIX}$", error)
+
+    call mpi_win_shared_query(win, 0, local_length, disp_unit, baseptr, error1)
+    call handle_errorflag(error1, "MPI_WIN_SHARED_QUERY in mpifx_allocate_shared_${SUFFIX}$", error)
+
+    call c_f_pointer(baseptr, shared_data, [length])
+
+  end subroutine mpifx_allocate_shared_${SUFFIX}$
+
+#:enddef mpifx_allocate_shared_template
+
+  !> Deallocates a memory associated with a shared memory segment.
+  !!
+  !! \param win  Handle of the shared memory window.
+  !! \param error  Optional error code on return.
+  !!
+  !! \see MPI documentation (\c MPI_WIN_FREE)
+  !!
+  subroutine mpifx_free_shared(win, error)
+    integer, intent(inout) :: win
+    integer, intent(out), optional :: error
+
+    integer :: error0
+
+    call mpi_win_free(win, error0)
+    call handle_errorflag(error0, "MPI_WIN_FREE in mpifx_free_shared", error)
+
+  end subroutine mpifx_free_shared
+
+  !> Locks a shared memory segment.
+  !!
+  !! \param win  Handle of the shared memory window.
+  !! \param error  Optional error code on return.
+  !!
+  !! \see MPI documentation (\c MPI_WIN_LOCK_ALL)
+  !!
+  subroutine mpifx_lock_shared(win, error)
+    integer, intent(inout) :: win
+    integer, intent(out), optional :: error
+
+    integer :: error0
+
+    call mpi_win_lock_all(MPI_MODE_NOCHECK, win, error0)
+    call handle_errorflag(error0, "MPI_WIN_LOCK_ALL in mpifx_lock_shared", error)
+
+  end subroutine mpifx_lock_shared
+
+  !> Unlocks a shared memory segment.
+  !!
+  !! \param win  Handle of the shared memory window.
+  !! \param error  Optional error code on return.
+  !!
+  !! \see MPI documentation (\c MPI_WIN_UNLOCK_ALL)
+  !!
+  subroutine mpifx_unlock_shared(win, error)
+    integer, intent(inout) :: win
+    integer, intent(out), optional :: error
+
+    integer :: error0
+
+    call mpi_win_unlock_all(win, error0)
+    call handle_errorflag(error0, "MPI_WIN_UNLOCK_ALL in mpifx_unlock_shared", error)
+
+  end subroutine mpifx_unlock_shared
+
+  !> Synchronizes shared memory across MPI ranks.
+  !!
+  !! \param mycomm  MPI communicator.
+  !! \param win  Handle of the shared memory window.
+  !! \param error  Optional error code on return.
+  !!
+  !! \see MPI documentation (\c MPI_WIN_SYNC)
+  !!
+  subroutine mpifx_sync_shared(mycomm, win, error)
+    type(mpifx_comm), intent(in) :: mycomm
+    integer, intent(inout) :: win
+    integer, intent(out), optional :: error
+
+    integer :: error0, error1
+
+    call mpi_win_sync(win, error0)
+    call handle_errorflag(error0, "MPI_WIN_SYNC in mpifx_sync_shared", error)
+
+    call mpi_barrier(mycomm%id, error1)
+    call handle_errorflag(error1, "MPI_BARRIER in mpifx_sync_shared", error)
+
+  end subroutine mpifx_sync_shared
+
+
+#:for TYPE in TYPES
+  #:set FTYPE = FORTRAN_TYPES[TYPE]
+  #:set SUFFIX = TYPE_ABBREVS[TYPE]
+
+  $:mpifx_allocate_shared_template(SUFFIX, FTYPE)
+
+#:endfor
+
+end module mpifx_shared_memory_module

test/CMakeLists.txt

@@ -9,7 +9,8 @@ set(targets
   test_gatherv
   test_reduce
   test_scatter
-  test_scatterv)
+  test_scatterv
+  test_shared_memory)
 
 foreach(target IN LISTS targets)
   add_executable(${target} ${target}.f90)

test/meson.build

@@ -12,6 +12,7 @@ tests = [
   'reduce',
   'scatter',
   'scatterv',
+  'shared_memory',
 ]
 
 foreach t : tests

test/test_shared_memory.f90

@@ -0,0 +1,34 @@
+program test_shared_memory
+  use libmpifx_module
+  implicit none
+
+  type(mpifx_comm) :: globalcomm, nodecomm
+  integer, parameter :: length = 7
+  integer :: win
+  integer, pointer :: data_pointer(:)
+
+  call mpifx_init()
+  call globalcomm%init()
+
+  ! Create a new communicator for all ranks on a node first
+  call globalcomm%split_type(MPI_COMM_TYPE_SHARED, globalcomm%rank, nodecomm)
+
+  call mpifx_allocate_shared(nodecomm, length, win, data_pointer)
+
+  call mpifx_lock_shared(win)
+
+  ! Only rank 0 writes data into the array
+  if (nodecomm%lead) then
+    data_pointer(:) = 42
+  end if
+
+  call mpifx_sync_shared(nodecomm, win)
+  call mpifx_unlock_shared(win)
+
+  ! All ranks on the node will read the same value
+  write(*, "(2(A,1X,I0,1X))") "ID:", nodecomm%rank, "VALUE:", data_pointer(1)
+
+  call mpifx_free_shared(win)
+  call mpifx_finalize()
+
+end program test_shared_memory