Shmem_implementation.F90

This file depends on

Help
Source Code

#define SHM_SUCCESS  0
#include "unused_dummy.H"
#include "MAPL_ErrLog.h"

submodule (MAPL_Shmem) Shmem_implementation
  use pflogger, only: logging, Logger
  use MAPL_ExceptionHandling
  use MAPL_Constants
  implicit none

  interface
     subroutine perror(s) bind(c,name="perror")
       use, intrinsic :: ISO_C_BINDING
       character(c_char), intent(in) :: s(*)
     end subroutine perror
  end interface

contains

  module procedure MAPL_GetNodeInfo

     integer :: STATUS

     if (MAPL_NodeComm == -1) then ! make sure that we do this only once
        MAPL_NodeComm = getNodeComm(comm, rc=STATUS)
        _VERIFY(STATUS)
     end if

     if (MAPL_NodeRootsComm == -1) then ! make sure that we do this only once
        MAPL_NodeRootsComm = getNodeRootsComm(comm, rc=STATUS)
        _VERIFY(STATUS)
     end if

     _RETURN(SHM_SUCCESS)
  end procedure MAPL_GetNodeInfo

  module procedure MAPL_InitializeShmem

     integer :: STATUS

     _ASSERT(MAPL_NodeComm /= -1,'needs informative message')

     allocate(Segs(CHUNK),stat=STATUS)
     _ASSERT(STATUS==0,'needs informative message')
     Segs(:)%shmid = -1
     Segs(:)%addr=C_NULL_PTR

     MAPL_ShmInitialized=.true.

#ifdef DEBUG
     if(MAPL_AmNodeRoot) &
          print *, "MAPL_Shmem initialized for node ", MAPL_MyNodeNum
#endif

     _RETURN(SHM_SUCCESS)
  end procedure MAPL_InitializeShmem

 module procedure MAPL_FinalizeShmem
    integer      :: status, i
    type (c_ptr) :: buf

    if (allocated(MAPL_NodeRankList)) then
       do i=1,size(MAPL_NodeRankList)
            if (associated(MAPL_NodeRankList(i)%rank)) then
               deallocate(MAPL_NodeRankList(i)%rank)
               MAPL_NodeRankList(i)%rank=>NULL()
            end if
         end do
         deallocate(MAPL_NodeRankList)
      end if

      if (associated(Segs)) then
         do i=1,size(Segs)
            if(Segs(i)%shmid==-1) cycle

!!! Everyone detaches address from shared segment

            STATUS = shmdt(Segs(i)%addr)
            _ASSERT(STATUS /= -1,'needs informative message')

!!! Make sure everyone has finished detaching

            call MPI_Barrier(MAPL_NodeComm, STATUS)
            _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')

!!! The root processor destroys the segment

            if (MAPL_AmNodeRoot) then
               STATUS = shmctl(Segs(i)%shmid, IPC_RMID, buf)
               _ASSERT(STATUS /= -1,'needs informative message')
            end if
         end do

         deallocate(Segs,stat=STATUS)
         _ASSERT(STATUS==0,'needs informative message')
      end if

      MAPL_ShmInitialized=.false.

#ifdef DEBUG
      if(MAPL_AmNodeRoot) &
           print *, "MAPL_Shmem finalized for node ", MAPL_MyNodeNum
#endif

      call MPI_Comm_free(MAPL_NodeComm, status)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')
      MAPL_NodeComm = -1

      if (MAPL_NodeRootsComm /= MPI_COMM_NULL) then
         call MPI_Comm_free(MAPL_NodeRootsComm, status)
         _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')
      end if
      MAPL_NodeRootsComm = -1

      MAPL_MyNodeNum=-1
      MAPL_AmNodeRoot=.false.

      MAPL_CoresPerNodeUsed=-1
      MAPL_CoresPerNodeMin=-1
      MAPL_CoresPerNodeMax=-1
      MAPL_NumNodes=-1

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_FinalizeShmem

    module procedure MAPL_DeAllocNodeArray_1DL4

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_1DL4

    module procedure MAPL_DeAllocNodeArray_1DI4

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_1DI4

    module procedure MAPL_DeAllocNodeArray_2DI4

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_2DI4

    module procedure MAPL_DeAllocNodeArray_3DI4

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2),lbound(Ptr,3)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_3DI4

    module procedure MAPL_DeAllocNodeArray_4DI4

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2),lbound(Ptr,3),lbound(Ptr,4)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_4DI4


    module procedure MAPL_DeAllocNodeArray_1DR4

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_1DR4

    module procedure MAPL_DeAllocNodeArray_2DR4

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_2DR4

    module procedure MAPL_DeAllocNodeArray_3DR4

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2),lbound(Ptr,3)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_3DR4

    module procedure MAPL_DeAllocNodeArray_4DR4

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2),lbound(Ptr,3),lbound(Ptr,4)))
      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_4DR4


    module procedure MAPL_DeAllocNodeArray_1DR8

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_1DR8

    module procedure MAPL_DeAllocNodeArray_2DR8

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_2DR8

    module procedure MAPL_DeAllocNodeArray_3DR8

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2),lbound(Ptr,3)))

      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_3DR8

    module procedure MAPL_DeAllocNodeArray_4DR8

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2),lbound(Ptr,3),lbound(Ptr,4)))
      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_4DR8

    module procedure MAPL_DeAllocNodeArray_5DR8

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2),lbound(Ptr,3),lbound(Ptr,4),lbound(Ptr,5)))
      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_5DR8

    module procedure MAPL_DeAllocNodeArray_6DR8

      type(c_ptr) :: Caddr
      integer     :: STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      Caddr = C_Loc(Ptr(lbound(Ptr,1),lbound(Ptr,2),lbound(Ptr,3),lbound(Ptr,4),lbound(Ptr,5),lbound(Ptr,6)))
      call ReleaseSharedMemory(Caddr,rc=STATUS)
      _VERIFY(STATUS)

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_DeAllocNodeArray_6DR8

    module procedure MAPL_AllocNodeArray_1DL4
    implicit none
      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len = shp(1)

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(size(Ptr)==len,'needs informative message')

      if(present(lbd)) Ptr(lbd(1):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_1DL4

    module procedure MAPL_AllocNodeArray_1DI4

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len = shp(1)

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(size(Ptr)==len,'needs informative message')

      if(present(lbd)) Ptr(lbd(1):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_1DI4


    module procedure MAPL_AllocNodeArray_2DI4

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_2DI4

    module procedure MAPL_AllocNodeArray_3DI4

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):,lbd(3):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_3DI4

    module procedure MAPL_AllocNodeArray_4DI4

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):,lbd(3):,lbd(4):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_4DI4


    module procedure MAPL_AllocNodeArray_1DR4

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len = shp(1)

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(size(Ptr)==len,'needs informative message')

      if(present(lbd)) Ptr(lbd(1):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_1DR4


    module procedure MAPL_AllocNodeArray_2DR4

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_2DR4

    module procedure MAPL_AllocNodeArray_3DR4

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):,lbd(3):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_3DR4

    module procedure MAPL_AllocNodeArray_4DR4

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):,lbd(3):,lbd(4):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_4DR4


    module procedure MAPL_AllocNodeArray_1DR8

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len = shp(1)*2

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr

      if(present(lbd)) Ptr(lbd(1):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_1DR8


    module procedure MAPL_AllocNodeArray_2DR8

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)*2

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_2DR8

    module procedure MAPL_AllocNodeArray_3DR8

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)*2

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):,lbd(3):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_3DR8

    module procedure MAPL_AllocNodeArray_4DR8

      type(c_ptr) :: Caddr
      integer len, STATUS

      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)*2

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):,lbd(3):,lbd(4):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_4DR8

    module procedure MAPL_AllocNodeArray_5DR8

      type(c_ptr) :: Caddr
      integer len, STATUS

      _UNUSED_DUMMY(lbd)
      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)*2

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):,lbd(3):,lbd(4):,lbd(5):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_5DR8

    module procedure MAPL_AllocNodeArray_6DR8

      type(c_ptr) :: Caddr
      integer len, STATUS

      _UNUSED_DUMMY(lbd)
      if(.not.MAPL_ShmInitialized) then
         _RETURN(MAPL_NoShm)
      endif

      len=product(Shp)*2

      call GetSharedMemory(Caddr, len, rc=STATUS)
      _VERIFY(STATUS)

      call c_f_pointer(Caddr, Ptr, Shp) ! C ptr to Fortran ptr
      _ASSERT(all(shape(Ptr)==Shp),'needs informative message')

      if(present(lbd)) Ptr(lbd(1):,lbd(2):,lbd(3):,lbd(4):,lbd(5):,lbd(6):) => Ptr

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_AllocNodeArray_6DR8


    module procedure MAPL_AllocateShared_1DL4

      integer :: status

      if(MAPL_ShmInitialized) then
         call MAPL_AllocNodeArray(Ptr, Shp, lbd, rc=STATUS)
         _VERIFY(STATUS)
      else
         if (TransRoot) then
            allocate(Ptr(Shp(1)),stat=status)
         else
            allocate(Ptr(0),stat=status)
         end if
         _VERIFY(STATUS)
      endif

      _RETURN(STATUS)

    end procedure MAPL_AllocateShared_1DL4

    module procedure MAPL_AllocateShared_1DI4


      integer :: status

      if(MAPL_ShmInitialized) then
         call MAPL_AllocNodeArray(Ptr, Shp, lbd, rc=STATUS)
         _VERIFY(STATUS)
      else
         if (TransRoot) then
            allocate(Ptr(Shp(1)),stat=status)
         else
            allocate(Ptr(0),stat=status)
         end if
         _VERIFY(STATUS)
      endif

      _RETURN(STATUS)

    end procedure MAPL_AllocateShared_1DI4

    module procedure MAPL_AllocateShared_1DR4


      integer :: status

      if(MAPL_ShmInitialized) then
         call MAPL_AllocNodeArray(Ptr, Shp, lbd, rc=STATUS)
         _VERIFY(STATUS)
      else
         if (TransRoot) then
            allocate(Ptr(Shp(1)),stat=status)
         else
            allocate(Ptr(0),stat=status)
         end if
         _VERIFY(STATUS)
      endif

      _RETURN(STATUS)

    end procedure MAPL_AllocateShared_1DR4

    module procedure MAPL_AllocateShared_1DR8


      integer :: status

      if(MAPL_ShmInitialized) then
         call MAPL_AllocNodeArray(Ptr, Shp, lbd, rc=STATUS)
         _VERIFY(STATUS)
      else
         if (TransRoot) then
            allocate(Ptr(Shp(1)),stat=status)
         else
            allocate(Ptr(0),stat=status)
         end if
         _VERIFY(STATUS)
      endif

      _RETURN(STATUS)

    end procedure MAPL_AllocateShared_1DR8

    module procedure MAPL_AllocateShared_2DI4
      integer :: status
      if(MAPL_ShmInitialized) then
         call MAPL_AllocNodeArray(Ptr, Shp, lbd, _RC)
      else
         if (TransRoot) then
            allocate(Ptr(Shp(1),Shp(2)),stat=status)
         else
            allocate(Ptr(0,0),stat=status)
         end if
         _VERIFY(STATUS)
      endif

      _RETURN(STATUS)

    end procedure MAPL_AllocateShared_2DI4

    module procedure MAPL_AllocateShared_2DR4


      integer :: status

      if(MAPL_ShmInitialized) then
         call MAPL_AllocNodeArray(Ptr, Shp, lbd, rc=STATUS)
         _VERIFY(STATUS)
      else
         if (TransRoot) then
            allocate(Ptr(Shp(1),Shp(2)),stat=status)
         else
            allocate(Ptr(0,0),stat=status)
         end if
         _VERIFY(STATUS)
      endif

      _RETURN(STATUS)

    end procedure MAPL_AllocateShared_2DR4

    module procedure MAPL_AllocateShared_2DR8


      integer :: status

      if(MAPL_ShmInitialized) then
         call MAPL_AllocNodeArray(Ptr, Shp, lbd, rc=STATUS)
         _VERIFY(STATUS)
      else
         if (TransRoot) then
            allocate(Ptr(Shp(1),Shp(2)),stat=status)
         else
            allocate(Ptr(0,0),stat=status)
         end if
         _VERIFY(STATUS)
      endif

      _RETURN(STATUS)

    end procedure MAPL_AllocateShared_2DR8

    module procedure ReleaseSharedMemory
      integer        :: pos
      type (c_ptr)   :: buf
      integer        :: STATUS

!!! Find the segment in the segment list

      do pos=1,size(Segs)
         if(Segs(pos)%shmid == -1) cycle
         if(c_associated(Segs(pos)%addr,Caddr)) exit
      end do

!!! Everyone exits if it is not there

      _ASSERT(pos<=size(Segs),'needs informative message')

!!! The root processor destroys the segment

      if (MAPL_AmNodeRoot) then
         STATUS = shmctl(Segs(pos)%shmid, IPC_RMID, buf)
         _ASSERT(STATUS /= -1,'needs informative message')
      end if

!!! Everyone detaches address from shared segment

      status = shmdt(Caddr)
      _ASSERT(status /= -1,'needs informative message')

!!! Make sure everyone has finished detaching

      call MPI_Barrier(MAPL_NodeComm, STATUS)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')

!!! The root processor destroys the segment
!
!     if (MAPL_AmNodeRoot) then
!        STATUS = shmctl(Segs(pos)%shmid, IPC_RMID, buf)
!        _ASSERT(STATUS /= -1,'needs informative message')
!     end if

!!! Free the position in the segment list

      Segs(pos)%shmid=-1
      Segs(pos)%addr=C_NULL_PTR

      _RETURN(SHM_SUCCESS)
    end procedure ReleaseSharedMemory


    module procedure GetSharedMemory

      integer                   :: status, pos
      integer(c_key_t)          :: key
      integer(c_size_t)         :: numBytes
      integer, parameter        :: WORD_SIZE = 4
      integer(c_int), parameter :: C_ZERO = 0
      integer(c_int), parameter :: myflg = int(o'666')
      integer(c_int), parameter :: shmflg = int(ior(IPC_CREAT,myflg))
      integer(c_key_t), parameter :: keypre = 456000000

!!! Get an empty spot in the list of allocated segments
!!! and use its index as the segment's key

      pos=1
      do while(pos<=size(Segs))
         if(Segs(pos)%shmid==-1) exit ! Found an available spot

         if(pos==size(Segs)) then ! Expand the segment list
            allocate(SegsNew(size(Segs)+CHUNK),stat=STATUS)
            _ASSERT(STATUS==0,'needs informative message')
            SegsNew(:)%shmid = -1
            SegsNew(:)%addr=C_NULL_PTR

            SegsNew(1:size(Segs)) = Segs

            deallocate(Segs,stat=STATUS)
            _ASSERT(STATUS==0,'needs informative message')

            Segs=>SegsNew
            nullify(SegsNew)
         end if

         pos = pos + 1
      end do

      key = keypre + pos

!!!  Create the segment in root and have other processors
!!!  get the segment id using the common key

      numBytes = WORD_SIZE*len

      if (MAPL_AmNodeRoot) then ! root process creates segment
         Segs(pos)%shmid = shmget(key, numBytes, shmflg)
         if (Segs(pos)%shmid < 0) then
            call perror('server shmget():'//C_NULL_CHAR)
            _FAIL('needs informative message')
         end if
         call MPI_Barrier(MAPL_NodeComm, STATUS)
         _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')
      else                 ! wait for create on root & get segment
         call MPI_Barrier(MAPL_NodeComm, STATUS)
         _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')
         Segs(pos)%shmid = shmget(key, numBytes, myflg)
         _ASSERT(Segs(pos)%shmid /= -1,'needs informative message')
      end if

!!! Everyone attaches the memory to their own C pointer

      Segs(pos)%addr= shmat(Segs(pos)%shmid, C_NULL_PTR, C_ZERO)

!!! Check that we have valid shared memory

      _ASSERT(c_associated(Segs(pos)%addr),'needs informative message')

!!! Return C address. It will be attached to a Fortran pointer
!!!  with rank overloads

      Caddr = Segs(pos)%addr

      _RETURN(SHM_SUCCESS)
    end procedure GetSharedMemory

    module procedure BroadcastToNodes_1DR4
      integer :: STATUS

      real(kind=REAL32), allocatable :: ldata(:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      end if

      allocate(ldata(size(data,1)),stat=status)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_REAL, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_1DR4

    module procedure BroadcastToNodes_2DR4
      integer :: STATUS

      real(kind=REAL32), allocatable :: ldata(:,:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      end if

      allocate(ldata(size(data,1),size(data,2)),stat=status)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_REAL, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_2DR4

    module procedure BroadcastToNodes_3DR4
      integer :: STATUS

      real, allocatable :: ldata(:,:,:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      endif

      allocate(ldata(size(data,1),size(data,2),size(data,3)),stat=STATUS)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_REAL, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_3DR4

    module procedure BroadcastToNodes_4DR4
      integer :: STATUS

      real, allocatable :: ldata(:,:,:,:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      endif

      allocate(ldata(size(data,1),size(data,2),size(data,3),size(data,4)),stat=STATUS)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_REAL, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_4DR4

    module procedure BroadcastToNodes_1DR8
      integer :: STATUS

      real(kind=REAL64), allocatable :: ldata(:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      endif

      allocate(ldata(size(data,1)),stat=STATUS)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_DOUBLE_PRECISION, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_1DR8

    module procedure BroadcastToNodes_2DR8
      integer :: STATUS

      real(kind=REAL64), allocatable :: ldata(:,:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      endif

      allocate(ldata(size(data,1),size(data,2)),stat=STATUS)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_DOUBLE_PRECISION, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_2DR8

    module procedure BroadcastToNodes_3DR8
      integer :: STATUS

      real(kind=REAL64), allocatable :: ldata(:,:,:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      endif

      allocate(ldata(size(data,1),size(data,2),size(data,3)),stat=STATUS)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_DOUBLE_PRECISION, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_3DR8

    module procedure BroadcastToNodes_4DR8
      integer :: STATUS

      real(kind=REAL64), allocatable :: ldata(:,:,:,:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      endif

      allocate(ldata(size(data,1),size(data,2),size(data,3),size(data,4)),stat=STATUS)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_DOUBLE_PRECISION, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_4DR8

    module procedure BroadcastToNodes_1DI4
      integer :: STATUS

      integer, allocatable :: ldata(:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      endif

      allocate(ldata(size(data,1)),stat=STATUS)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_INTEGER, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_1DI4

    module procedure BroadcastToNodes_2DI4
      integer :: STATUS

      integer, allocatable :: ldata(:,:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      endif

      allocate(ldata(size(data,1),size(data,2)),stat=STATUS)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_INTEGER, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_2DI4

    module procedure BroadcastToNodes_3DI4
      integer :: STATUS

      integer, allocatable :: ldata(:,:,:)

      if(.not.MAPL_ShmInitialized .or. MAPL_NodeRootsComm==MPI_COMM_NULL) THEN
         _RETURN(SHM_SUCCESS)
      endif

      allocate(ldata(size(data,1),size(data,2),size(data,3)),stat=STATUS)
      _VERIFY(STATUS)
      ldata = data
      call MPI_Bcast(LDATA, N, MPI_INTEGER, ROOT, MAPL_NodeRootsComm, STATUS)
      _VERIFY(STATUS)
      data = ldata
      deallocate(ldata)

      _RETURN(SHM_SUCCESS)
    end procedure BroadcastToNodes_3DI4

    module procedure MAPL_SyncSharedMemory
      integer :: STATUS
      if(.not.MAPL_ShmInitialized) then
         _RETURN(SHM_SUCCESS)
      endif
!!! Make sure everyone on a node syncs
      call MPI_Barrier(MAPL_NodeComm, STATUS)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')
      _RETURN(SHM_SUCCESS)
    end procedure MAPL_SyncSharedMemory

    module procedure MAPL_GetNewRank

      rank = MAPL_NodeRankList(node)%RankLastUsed+1
      if (rank > size(MAPL_NodeRankList(node)%rank)) then
         rank = 1
      end if
      MAPL_NodeRankList(node)%rankLastUsed=rank

      _RETURN(SHM_SUCCESS)

    end procedure MAPL_GetNewRank

    module procedure getNodeComm
      use MAPL_SortMod

      integer, allocatable :: colors(:), ranks(:)
      integer :: last
      integer :: i, n

      character(len=MPI_MAX_PROCESSOR_NAME) :: name
      character(len=MPI_MAX_PROCESSOR_NAME), allocatable :: names(:)

      integer :: len, STATUS, MyColor, NumColors, npes, rank
      integer :: NumCores
      integer :: nodeRank

      integer :: i1, i2
      integer, allocatable :: newNode(:)
      class(Logger), pointer :: lgr

      NodeComm=MPI_COMM_NULL

      call MPI_Get_processor_name(name,len,STATUS)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')

      call MPI_COMM_RANK(Comm, rank, STATUS)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')
      call MPI_COMM_SIZE(Comm, npes, STATUS)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')

      allocate(names(npes),stat=STATUS)
      _ASSERT(STATUS==0,'needs informative message')

      call MPI_AllGather(name ,MPI_MAX_PROCESSOR_NAME,MPI_CHARACTER,&
                         names,MPI_MAX_PROCESSOR_NAME,MPI_CHARACTER,Comm,status)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')

      myColor = getColor(name, names)

      ! We are ready to split communicators

      call MPI_COMM_SPLIT(Comm, MyColor, rank, NodeComm, STATUS)
      _ASSERT(NodeComm/=MPI_COMM_NULL,'needs informative message')

      call MPI_COMM_SIZE(NodeComm, NumCores, STATUS)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')

      allocate(colors(npes), ranks(npes), stat=STATUS)
      _ASSERT(STATUS==0,'needs informative message')
      do i=1,npes
         ranks(i) = i-1
      end do

      call MPI_AllGather(myColor, 1, MPI_INTEGER,&
                         colors,  1, MPI_INTEGER,Comm,status)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')

      call MAPL_Sort(COLORS,ranks)
      last = 0
      n = 0
      allocate(newNode(npes+1),stat=status)
      _VERIFY(STATUS)
      newNode = 0
      do i=1,npes
         if(last /= colors(i)) then
            last = colors(i)
            n = n + 1
            newNode(n) = i
         end if
         ! We are done with COLORS, now we reuse the space to store NodeId
         colors(i) = n
      end do
      NumColors = n
      MAPL_NumNodes = NumColors
      do i=1,size(ranks)
         if (ranks(i) == rank) then
            MAPL_MyNodeNum = colors(i)
            exit
         end if
      end do

      newNode(NumColors+1) = npes+1
      allocate(MAPL_NodeRankList(NumColors), stat=status)
      _VERIFY(STATUS)
      do i=1,NumColors
         i1=newNode(i)
         i2=newNode(i+1)-1
         allocate(MAPL_NodeRankList(i)%rank(i2-i1+1),stat=status)
         _VERIFY(STATUS)
         MAPL_NodeRankList(i)%rank=ranks(i1:i2)
         call MAPL_Sort(MAPL_NodeRankList(i)%rank)
      end do
      deallocate(newNode)

      do i=1,size(MAPL_NodeRankList)
         MAPL_NodeRankList(i)%RankLastUsed=1
      enddo

      deallocate(ranks)
      deallocate(colors)

      MAPL_CoresPerNodeUsed = NumCores

      call MPI_Comm_rank(NodeComm, nodeRank, STATUS)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')

      MAPL_AmNodeRoot = nodeRank==0

      if (MAPL_AmNodeRoot) then
         _ASSERT(MAPL_NodeRankList(MAPL_MyNodeNum)%rank(1) == rank,'needs informative message')
      end if

!     we store the global Min and Max of CoresPerNode
      call MPI_AllReduce (MAPL_CoresPerNodeUsed, MAPL_CoresPerNodeMin, &
                          1, MPI_INTEGER, MPI_MIN, comm, status )
      _VERIFY(STATUS)
      call MPI_AllReduce (MAPL_CoresPerNodeUsed, MAPL_CoresPerNodeMax, &
                          1, MPI_INTEGER, MPI_MAX, comm, status )
      _VERIFY(STATUS)

      lgr => logging%get_logger('MAPL.SHMEM')

      if(rank==0) then
         if (MAPL_CoresPerNodeMin == MAPL_CoresPerNodeMax) then
            call lgr%info("NumCores per Node = %i0", NumCores)
         else
            call lgr%info("NumCores per Node varies from %i0 to %i0", &
                 MAPL_CoresPerNodeMin, MAPL_CoresPerNodeMax)
         end if
         call lgr%info("NumNodes in use   = %i0", NumColors)
         call lgr%info("Total PEs         = %i0", npes)
      end if

      deallocate(names,stat=STATUS)
      _ASSERT(STATUS==0,'needs informative message')

      _RETURN(SHM_SUCCESS)
    contains
      function getColor(name, sampleNames) result(color)
        character(len=*), intent(in) :: name
        character(len=*), intent(in) :: sampleNames(:)
        integer :: color

        integer :: i

        color = 0 ! unless
        do i = 1, size(sampleNames)
           if (trim(name) == trim(sampleNames(i))) then
              color = i
              exit
           end if
        end do

      end function getColor

    end procedure getNodeComm

    module procedure getNodeRootsComm

      integer :: STATUS, MyColor, NumNodes, npes, rank
      class(Logger), pointer :: lgr

      NodeRootsComm=MPI_COMM_NULL

      call MPI_COMM_RANK(Comm, rank, STATUS)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')
      call MPI_COMM_SIZE(Comm, npes, STATUS)
      _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')

      myColor = 0
      if (MAPL_AmNodeRoot) myColor = 1

      ! We are ready to split communicators

      call MPI_COMM_SPLIT(Comm, MyColor, rank, NodeRootsComm, STATUS)
      _ASSERT(NodeRootsComm/=MPI_COMM_NULL,'needs informative message')

      if (myColor==0) then
      ! Set nodes outside of this comm back to null
         NodeRootsComm=MPI_COMM_NULL
      else
      ! Confirm we have the proper communicator
         call MPI_COMM_SIZE(NodeRootsComm, NumNodes, STATUS)
         _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')
         ! additional sanity checks
         _ASSERT(MAPL_NumNodes == NumNodes,'needs informative message')
         call MPI_COMM_RANK(NodeRootsComm, rank, STATUS)
         _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')
         _ASSERT(MAPL_MyNodeNum == rank+1,'needs informative message')
      endif

      lgr => logging%get_logger('MAPL.SHMEM')

      if(rank==0) then
         call lgr%info("NumNodes in use  = %i0", NumNodes)
      end if

      _RETURN(SHM_SUCCESS)

    end procedure getNodeRootsComm



    module procedure MAPL_ShmemAmOnFirstNode

      integer :: status, rank

      if ( MAPL_NodeComm == -1 ) then
           call MAPL_GetNodeInfo(comm, rc=STATUS )
           _VERIFY(STATUS)
      end if

      a = .false.
      if (MAPL_MyNodeNum == 1) then
         if (MAPL_ShmInitialized) then
            a = .true.
         else
            call MPI_Comm_rank(comm, rank, STATUS)
            _ASSERT(STATUS==MPI_SUCCESS,'needs informative message')
            a = (rank == 0)
         end if
      end if

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_ShmemAmOnFirstNode

    module procedure MAPL_CoresPerNodeGet

      integer :: status

      if ( MAPL_NodeComm == -1 ) then
           call MAPL_GetNodeInfo(comm, rc=STATUS )
           _VERIFY(STATUS)
      end if

      MAPL_CoresPerNodeGet = MAPL_CoresPerNodeUsed

      _RETURN(SHM_SUCCESS)
    end procedure MAPL_CoresPerNodeGet

  end submodule Shmem_implementation
Shmem_implementation.F90 Source File

Contents

Submodules

Source Code

This file depends on

Source Code
