ecearth3/sources/oasis3-mct/lib/mct/mct/m_GlobalSegMapComms.F90

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!-----------------------------------------------------------------------
! CVS m_GlobalSegMapComms.F90,v 1.6 2004-04-23 23:58:47 jacob Exp
! CVS MCT_2_8_0 
!BOP -------------------------------------------------------------------
!
! !MODULE: m_GlobalSegMapComms - GlobalSegMap Communications Support
!
! !DESCRIPTION:
!
! This module provides communications support for the {\tt GlobalSegMap} 
! datatype.  Both blocking and non-blocking point-to-point communications 
! are provided for send (analogues to {\tt MPI\_SEND()/MPI\_ISEND()})
! A receive and broadcast method is also supplied.
!
! !INTERFACE:

 module m_GlobalSegMapComms

      implicit none

      private   ! except

! !PUBLIC MEMBER FUNCTIONS:

      public :: send
      public :: recv
      public :: isend
      public :: bcast

      interface bcast ; module procedure bcast_ ; end interface
      interface send  ; module procedure send_  ; end interface
      interface recv  ; module procedure recv_  ; end interface
      interface isend ; module procedure isend_ ; end interface

! !REVISION HISTORY:
! 11Aug03 - J.W. Larson <larson@mcs.anl.gov> - initial version
!
!EOP ___________________________________________________________________

  character(len=*),parameter :: myname='MCT::m_GlobalSegMapComms'

 contains

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: send_ - Point-to-point blocking Send of a GlobalSegMap
!
! !DESCRIPTION:
! This routine performs a blocking send of a {\tt GlobalSegMap} (the 
! input argument {\tt outgoingGSMap}) to the root processor on component
! {\tt comp\_id}. The input {\tt INTEGER} argument {\tt TagBase} 
! is used to generate tags for the messages associated with this operation; 
! there are six messages involved, so the user should avoid using tag 
! values {\tt TagBase} and {\tt TagBase + 5}.  All six messages are blocking.
! The success (failure) of this operation is reported in the zero 
! (non-zero) value of the optional {\tt INTEGER} output variable {\tt status}.
!
! !INTERFACE:

 subroutine send_(outgoingGSMap, comp_id, TagBase, status)

!
! !USES:
!
      use m_mpif90
      use m_die, only : MP_perr_die,die
      use m_stdio

      use m_GlobalSegMap, only : GlobalSegMap
      use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg
      use m_GlobalSegMap, only : GlobalSegMap_comp_id => comp_ID
      use m_GlobalSegMap, only : GlobalSegMap_gsize => gsize

      use m_MCTWorld, only : ComponentToWorldRank
      use m_MCTWorld, only : ThisMCTWorld

      implicit none

! !INPUT PARAMETERS:

  type(GlobalSegMap),    intent(IN)  :: outgoingGSMap
  integer,               intent(IN)  :: comp_id
  integer,               intent(IN)  :: TagBase

! !OUTPUT PARAMETERS: 

  integer, optional,     intent(OUT) :: status

! !REVISION HISTORY:
! 13Aug03 - J.W. Larson <larson@mcs.anl.gov> - API and initial version.
! 26Aug03 - R. Jacob <jacob@mcs.anl.gov> - use same method as isend_
! 05Mar04 - R. Jacob <jacob@mcs.anl.gov> - match new isend_ method.
!EOP ___________________________________________________________________
  character(len=*),parameter :: myname_=myname//'::send_'

  integer :: ierr
  integer :: destID
  integer :: nsegs

  if(present(status)) status = 0 ! the success value

  destID = ComponentToWorldRank(0, comp_id, ThisMCTWorld)

       ! Next, send the buffer size to destID so it can prepare a
       ! receive buffer of the correct size.
  nsegs = GlobalSegMap_ngseg(outgoingGSMap)

  call MPI_SEND(outgoingGSMap%comp_id, 1, MP_Type(outgoingGSMap%comp_id), destID, &
                TagBase, ThisMCTWorld%MCT_comm, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send compid failed',ierr)
  endif

  call MPI_SEND(outgoingGSMap%ngseg, 1, MP_Type(outgoingGSMap%ngseg), destID, &
                TagBase+1, ThisMCTWorld%MCT_comm, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send ngseg failed',ierr)
  endif

  call MPI_SEND(outgoingGSMap%gsize, 1, MP_Type(outgoingGSMap%gsize), destID, &
                TagBase+2, ThisMCTWorld%MCT_comm, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send gsize failed',ierr)
  endif


       ! Send segment information data (3 messages)

  call MPI_SEND(outgoingGSMap%start, nsegs, &
                MP_Type(outgoingGSMap%start(1)), &
                destID, TagBase+3, ThisMCTWorld%MCT_comm, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send outgoingGSMap%start failed',ierr)
  endif

  call MPI_SEND(outgoingGSMap%length, nsegs, &
                MP_Type(outgoingGSMap%length(1)), &
                destID, TagBase+4, ThisMCTWorld%MCT_comm, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send outgoingGSMap%length failed',ierr)
  endif

  call MPI_SEND(outgoingGSMap%pe_loc, nsegs, &
                MP_Type(outgoingGSMap%pe_loc(1)), &
                destID, TagBase+5, ThisMCTWorld%MCT_comm, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send outgoingGSMap%pe_loc failed',ierr)
  endif

 end subroutine send_

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: isend_ - Point-to-point Non-blocking Send of a GlobalSegMap
!
! !DESCRIPTION:
! This routine performs a non-blocking send of a {\tt GlobalSegMap} (the 
! input argument {\tt outgoingGSMap}) to the root processor on component
! {\tt comp\_id}  The input {\tt INTEGER} argument {\tt TagBase} 
! is used to generate tags for the messages associated with this operation; 
! there are six messages involved, so the user should avoid using tag 
! values {\tt TagBase} and {\tt TagBase + 5}.  All six messages are non-
! blocking, and the request handles for them are returned in the output
! {\tt INTEGER} array {\tt reqHandle}, which can be checked for completion 
! using any of MPI's wait functions.  The success (failure) of 
! this operation is reported in the zero (non-zero) value of the optional 
! {\tt INTEGER} output variable {\tt status}.
!
! {\bf N.B.}:  Data is sent directly out of {\tt outgoingGSMap} so it
! must not be deleted until the send has completed.
!
! {\bf N.B.}:  The array {\tt reqHandle} represents allocated memory that 
! must be deallocated when it is no longer needed.  Failure to do so will 
! create a memory leak.
!
! !INTERFACE:

 subroutine isend_(outgoingGSMap, comp_id, TagBase, reqHandle, status)

!
! !USES:
!
      use m_mpif90
      use m_die, only : MP_perr_die,die
      use m_stdio

      use m_GlobalSegMap, only : GlobalSegMap
      use m_GlobalSegMap, only : GlobalSegMap_ngseg => ngseg

      use m_MCTWorld, only : ComponentToWorldRank
      use m_MCTWorld, only : ThisMCTWorld

      implicit none

! !INPUT PARAMETERS:

  type(GlobalSegMap),    intent(IN)  :: outgoingGSMap
  integer,               intent(IN)  :: comp_id
  integer,               intent(IN)  :: TagBase

! !OUTPUT PARAMETERS: 

  integer, dimension(:), pointer     :: reqHandle
  integer, optional,     intent(OUT) :: status

! !REVISION HISTORY:
! 13Aug03 - J.W. Larson <larson@mcs.anl.gov> - API and initial version.
! 05Mar04 - R. Jacob <jacob@mcs.anl.gov> - Send everything directly out
!           of input GSMap.  Don't use a SendBuffer.
!
!EOP ___________________________________________________________________

  character(len=*),parameter :: myname_=myname//'::isend_'

  integer :: ierr,destID,nsegs

  if(present(status)) status = 0 ! the success value

  destID = ComponentToWorldRank(0, comp_id, ThisMCTWorld)

  allocate(reqHandle(6), stat=ierr)
  if(ierr /= 0) then
     write(stderr,'(2a,i8)') myname_, &
	  'FATAL--allocation of send buffer failed with ierr=',ierr
     call die(myname_)
  endif

       ! Next, send the buffer size to destID so it can prepare a
       ! receive buffer of the correct size (3 messages).
  nsegs = GlobalSegMap_ngseg(outgoingGSMap)

  call MPI_ISEND(outgoingGSMap%comp_id, 1, MP_Type(outgoingGSMap%comp_id), destID, &
                TagBase, ThisMCTWorld%MCT_comm, reqHandle(1), ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send compid failed',ierr)
  endif

  call MPI_ISEND(outgoingGSMap%ngseg, 1, MP_Type(outgoingGSMap%ngseg), destID, &
                TagBase+1, ThisMCTWorld%MCT_comm, reqHandle(2), ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send ngseg failed',ierr)
  endif

  call MPI_ISEND(outgoingGSMap%gsize, 1, MP_Type(outgoingGSMap%gsize), destID, &
                TagBase+2, ThisMCTWorld%MCT_comm, reqHandle(3), ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send gsize failed',ierr)
  endif

       ! Send segment information data (3 messages)

  call MPI_ISEND(outgoingGSMap%start, nsegs, &
                MP_Type(outgoingGSMap%start(1)), &
                destID, TagBase+3, ThisMCTWorld%MCT_comm, reqHandle(4), ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send outgoingGSMap%start failed',ierr)
  endif

  call MPI_ISEND(outgoingGSMap%length, nsegs, &
                MP_Type(outgoingGSMap%length(1)), &
                destID, TagBase+4, ThisMCTWorld%MCT_comm, reqHandle(5), ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send outgoingGSMap%length failed',ierr)
  endif

  call MPI_ISEND(outgoingGSMap%pe_loc, nsegs, &
                MP_Type(outgoingGSMap%pe_loc(1)), &
                destID, TagBase+5, ThisMCTWorld%MCT_comm, reqHandle(6), ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Send outgoingGSMap%pe_loc failed',ierr)
  endif

 end subroutine isend_

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: recv_ - Point-to-point blocking Receive of a GlobalSegMap
!
! !DESCRIPTION:
! This routine performs a blocking receive of a {\tt GlobalSegMap} (the 
! input argument {\tt outgoingGSMap}) from the root processor on component
! {\tt comp\_id}. The input {\tt INTEGER} argument {\tt TagBase} 
! is used to generate tags for the messages associated with this operation; 
! there are six messages involved, so the user should avoid using tag 
! values {\tt TagBase} and {\tt TagBase + 5}. The success (failure) of this
! operation is reported in the zero (non-zero) value of the optional {\tt INTEGER} 
! output variable {\tt status}.
!
! !INTERFACE:

 subroutine recv_(incomingGSMap, comp_id, TagBase, status)

!
! !USES:
!
      use m_mpif90
      use m_die, only : MP_perr_die, die
      use m_stdio

      use m_GlobalSegMap, only : GlobalSegMap
      use m_GlobalSegMap, only : GlobalSegMap_init => init

      use m_MCTWorld, only : ComponentToWorldRank
      use m_MCTWorld, only : ThisMCTWorld

      implicit none

! !INPUT PARAMETERS:

  integer,               intent(IN)  :: comp_id
  integer,               intent(IN)  :: TagBase

! !OUTPUT PARAMETERS: 

  type(GlobalSegMap),    intent(OUT) :: incomingGSMap
  integer, optional,     intent(OUT) :: status

! !REVISION HISTORY:
! 13Aug03 - J.W. Larson <larson@mcs.anl.gov> - API and initial version.
! 25Aug03 - R.Jacob <larson@mcs.anl.gov> - rename to recv_.
!EOP ___________________________________________________________________

  character(len=*),parameter :: myname_=myname//'::recv_'

  integer :: ierr,sourceID
  integer :: MPstatus(MP_STATUS_SIZE)
  integer :: RecvBuffer(3)

  if(present(status)) status = 0 ! the success value

  sourceID = ComponentToWorldRank(0, comp_id, ThisMCTWorld)

       ! Receive the GlobalSegMap's basic constants:  component id,
       ! grid size, and number of segments.  The number of segments
       ! is needed to construct the arrays into which segment 
       ! information will be received.  Thus, this receive blocks.

  call MPI_RECV(RecvBuffer(1), 1, MP_Type(RecvBuffer(1)), sourceID, &
                TagBase, ThisMCTWorld%MCT_comm, MPstatus, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Receive of compid failed',ierr)
  endif
  call MPI_RECV(RecvBuffer(2), 1, MP_Type(RecvBuffer(2)), sourceID, &
                TagBase+1, ThisMCTWorld%MCT_comm, MPstatus, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Receive of ngseg failed',ierr)
  endif
  call MPI_RECV(RecvBuffer(3), 1, MP_Type(RecvBuffer(3)), sourceID, &
                TagBase+2, ThisMCTWorld%MCT_comm, MPstatus, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Receive of gsize failed',ierr)
  endif

       ! Create Empty GlobaSegMap into which segment information
       ! will be received

  call GlobalSegMap_init(incomingGSMap, RecvBuffer(1), RecvBuffer(2), &
                         RecvBuffer(3))

       ! Receive segment information data (3 messages)

  call MPI_RECV(incomingGSMap%start, RecvBuffer(2), &
                MP_Type(incomingGSMap%start(1)), &
                sourceID, TagBase+3, ThisMCTWorld%MCT_comm, MPstatus, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Recv incomingGSMap%start failed',ierr)
  endif

  call MPI_RECV(incomingGSMap%length, RecvBuffer(2), &
                MP_Type(incomingGSMap%length(1)), &
                sourceID, TagBase+4, ThisMCTWorld%MCT_comm, MPstatus, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Recv incomingGSMap%length failed',ierr)
  endif

  call MPI_RECV(incomingGSMap%pe_loc, RecvBuffer(2), &
                MP_Type(incomingGSMap%pe_loc(1)), &
                sourceID, TagBase+5, ThisMCTWorld%MCT_comm, MPstatus, ierr)
  if(ierr /= 0) then
     call MP_perr_die(myname_, 'Recv incomingGSMap%pe_loc failed',ierr)
  endif

 end subroutine recv_

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!    Math and Computer Science Division, Argonne National Laboratory   !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: bcast_ - broadcast a GlobalSegMap object
!
! !DESCRIPTION:
!
! The routine {\tt bcast\_()} takes the input/output {\em GlobalSegMap} 
! argument {\tt GSMap} (on input valid only on the {\tt root} process,
! on output valid on all processes) and broadcasts it to all processes
! on the communicator associated with the F90 handle {\tt comm}.  The
! success (failure) of this operation is returned as a zero (non-zero) 
! value of the optional output {\tt INTEGER} argument {\tt status}.
!
! !INTERFACE:

 subroutine bcast_(GSMap, root, comm, status)

!
! !USES:
!
      use m_mpif90
      use m_die, only : MP_perr_die,die
      use m_stdio

      use m_GlobalSegMap, only : GlobalSegMap

      implicit none

! !INPUT PARAMETERS:

      integer,            intent(in)     :: root
      integer,            intent(in)     :: comm

! !INPUT/OUTPUT PARAMETERS: 

      type(GlobalSegMap), intent(inout)  :: GSMap  ! Output GlobalSegMap

! !OUTPUT PARAMETERS: 

      integer, optional,  intent(out)    :: status ! global vector size

! !REVISION HISTORY:
! 17Oct01 - J.W. Larson <larson@mcs.anl.gov> - Initial version.
! 11Aug03 - J.W. Larson <larson@mcs.anl.gov> - Relocated from original
!           location in m_GlobalSegMap.
!EOP ___________________________________________________________________

  character(len=*),parameter :: myname_=myname//'::bcast_'

  integer :: myID, ierr, n
  integer, dimension(:), allocatable :: IntBuffer

       ! Step One:  which process am I?

  call MP_COMM_RANK(comm, myID, ierr)
  if(ierr /= 0) call MP_perr_die(myname_,'MP_comm_rank()',ierr)

       ! Step Two:  Broadcast the scalar bits of the GlobalSegMap from
       ! the root.

  allocate(IntBuffer(3), stat=ierr) ! allocate buffer space (all PEs)
  if(ierr /= 0) then
    if(.not. present(status)) then
       call die(myname_,'allocate(IntBuffer)',ierr)
    else
       write(stderr,*) myname_,':: error during allocate(IntBuffer)'
       status = 2
       return
    endif
  endif

  if(myID == root) then ! pack the buffer
     IntBuffer(1) = GSMap%comp_id
     IntBuffer(2) = GSMap%ngseg
     IntBuffer(3) = GSMap%gsize
  endif

  call MPI_BCAST(IntBuffer, 3, MP_type(IntBuffer(1)), root, comm, ierr)
  if(ierr /= 0) call MP_perr_die(myname_,'MPI_BCAST(IntBuffer)',ierr)

  if(myID /= root) then ! unpack from buffer to GSMap
     GSMap%comp_id = IntBuffer(1)
     GSMap%ngseg = IntBuffer(2)
     GSMap%gsize = IntBuffer(3)
  endif

  deallocate(IntBuffer, stat=ierr) ! deallocate buffer space
  if(ierr /= 0) then
    if(.not. present(status)) then
       call die(myname_,'deallocate(IntBuffer)',ierr)
    else
       write(stderr,*) myname_,':: error during deallocate(IntBuffer)'
       status = 4
       return
    endif
  endif

       ! Step Three:  Broadcast the vector bits of GSMap from the root.
       ! Pack them into one big array to save latency costs associated
       ! with multiple broadcasts.

  allocate(IntBuffer(3*GSMap%ngseg), stat=ierr) ! allocate buffer space (all PEs)
  if(ierr /= 0) then
    if(.not. present(status)) then
       call die(myname_,'second allocate(IntBuffer)',ierr)
    else
       write(stderr,*) myname_,':: error during second allocate(IntBuffer)'
       status = 5
       return
    endif
  endif 

  if(myID == root) then ! pack outgoing broadcast buffer
     do n=1,GSMap%ngseg
	IntBuffer(n) = GSMap%start(n)
	IntBuffer(GSMap%ngseg+n) = GSMap%length(n)
	IntBuffer(2*GSMap%ngseg+n) = GSMap%pe_loc(n)
     end do
  endif

  call MPI_BCAST(IntBuffer, 3*GSMap%ngseg, MP_Type(IntBuffer(1)), root, comm, ierr)
  if(ierr /= 0) call MP_perr_die(myname_,'Error in second MPI_BCAST(IntBuffer)',ierr)

  if(myID /= root) then ! Allocate GSMap%start, GSMap%length,...and fill them

     allocate(GSMap%start(GSMap%ngseg), GSMap%length(GSMap%ngseg), &
	      GSMap%pe_loc(GSMap%ngseg), stat=ierr)
     if(ierr /= 0) then
	if(.not. present(status)) then
	   call die(myname_,'off-root allocate(GSMap%start...)',ierr)
	else
	   write(stderr,*) myname_,':: error during off-root allocate(GSMap%start...)'
	   status = 7
	   return
	endif
     endif

     do n=1,GSMap%ngseg ! unpack the buffer into the GlobalSegMap
	GSMap%start(n) = IntBuffer(n)
	GSMap%length(n) = IntBuffer(GSMap%ngseg+n)
	GSMap%pe_loc(n) = IntBuffer(2*GSMap%ngseg+n)
     end do

  endif

       ! Clean up buffer space:

  deallocate(IntBuffer, stat=ierr) 
  if(ierr /= 0) then
    if(.not. present(status)) then
       call die(myname_,'second deallocate(IntBuffer)',ierr)
    else
       write(stderr,*) myname_,':: error during second deallocate(IntBuffer)'
       status = 8
       return
    endif
  endif 

 end subroutine bcast_

 end module m_GlobalSegMapComms