distribute_mod::mp_assemble Interface Reference

Public Member Functions
subroutine	mp_assemblef_1d (ng, model, npts, aspv, a, inpcomm)
subroutine	mp_assemblef_2d (ng, model, npts, aspv, a, inpcomm)
subroutine	mp_assemblef_3d (ng, model, npts, aspv, a, inpcomm)
subroutine	mp_assemblei_1d (ng, model, npts, aspv, a, inpcomm)
subroutine	mp_assemblei_2d (ng, model, npts, aspv, a, inpcomm)

Detailed Description

Definition at line 67 of file distribute.F.

Member Function/Subroutine Documentation

mp_assemblef_1d()

subroutine distribute_mod::mp_assemble::mp_assemblef_1d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	npts,
		real(r8), intent(in)	aspv,
		real(r8), dimension(:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 2278 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine assembles a 1D floating-point array from all members   !
!  in the group.  The collection of data from all nodes is achieved    !
!  as a reduction sum.                                                 !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Npts       Number of collected data points, PROD(SIZE(A)).       !
!     Aspv       Special value indicating that an array element is     !
!                  not operated by the current parallel node. It must  !
!                  be zero to collect data by a global reduction sum.  !
!     A          1D array to collect.                                  !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Assembled 1D array.                                   !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Npts
 
      integer, intent(in), optional :: InpComm
!
      real(r8), intent(in) :: Aspv
 
      real(r8), intent(inout) :: A(:)
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, MyNpts, Nnodes, Serror
      integer :: i, rank, request
 
      integer, dimension(MPI_STATUS_SIZE) :: status
!
# if defined ASSEMBLE_ALLGATHER
      real(r8), dimension(Npts,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
# elif defined ASSEMBLE_ALLREDUCE
      real(r8), dimension(Npts) :: Asend
# elif defined ASSEMBLE_SENDRECV
      real(r8), allocatable :: Arecv(:)
# endif
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_assemblef_1d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 70, __line__, myfile)
# endif
# ifdef MPI
!
!-----------------------------------------------------------------------
!  Set distributed-memory communicator handle (context ID).
!-----------------------------------------------------------------------
!
      IF (PRESENT(inpcomm)) THEN
        mycomm=inpcomm
      ELSE
        mycomm=ocn_comm_world
      END IF
# endif
!
!-----------------------------------------------------------------------
!  Check input parameters.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
# if defined ASSEMBLE_ALLGATHER
      bmemmax(ng)=max(bmemmax(ng), real(SIZE(arecv)*kind(a),r8))
# else
      bmemmax(ng)=max(bmemmax(ng), real(npts*kind(a),r8))
# endif
!
      mynpts=ubound(a, dim=1)
      IF (npts.ne.mynpts) THEN
        IF (master) THEN
          WRITE (stdout,10) npts, mynpts
        END IF
        exit_flag=7
      END IF
!
      IF (aspv.ne.0.0_r8) THEN
        IF (master) THEN
          WRITE (stdout,20) aspv
        END IF
        exit_flag=7
      END IF
!
!-----------------------------------------------------------------------
!  Collect data from all nodes.
!-----------------------------------------------------------------------
!
# if defined ASSEMBLE_ALLGATHER
      CALL mpi_allgather (a, npts, mp_float, arecv, npts, mp_float,     &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  Pack data according to special values: sum or ignore.
!
      nnodes=ntilei(ng)*ntilej(ng)-1
      IF (aspv.eq.0.0_r8) THEN
        DO i=1,npts
          a(i)=0.0_r8
          DO rank=0,nnodes
            a(i)=a(i)+arecv(i,rank)
          END DO
        END DO
      ELSE
        DO i=1,npts
          DO rank=0,nnodes
            IF (arecv(i,rank).ne.aspv) THEN
              a(i)=arecv(i,rank)
            END IF
          END DO
        END DO
      END IF
 
# elif defined ASSEMBLE_ALLREDUCE
!
!  Coppy data to send.
!
      DO i=1,npts
        asend(i)=a(i)
      END DO
!
!  Collect data from all nodes as a reduced sum.
!
      CALL mpi_allreduce (asend, a, npts, mp_float, mpi_sum,            &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_ALLREDUCE', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
 
# elif defined ASSEMBLE_SENDRECV
 
      IF (myrank.eq.mymaster) THEN
!
!  If master node, allocate and receive buffer.
!
        IF (.not.allocated(arecv)) THEN
          allocate (arecv(npts))
        END IF
!
!  If master node, loop over other nodes to receive and accumulate the
!  data.
!
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_irecv (arecv, npts, mp_float, rank, rank+5,          &
     &                    mycomm, request, myerror)
          CALL mpi_wait (request, status, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,30) 'MPI_IRECV', rank, myerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
          DO i=1,npts
            a(i)=a(i)+arecv(i)
          END DO
        END DO
        deallocate (arecv)
!
!  Otherwise, send data to master node.
!
      ELSE
        CALL mpi_isend (a, npts, mp_float, mymaster, myrank+5,          &
     &                  mycomm, request, myerror)
        CALL mpi_wait (request, status, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,30) 'MPI_ISEND', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast accumulated (full) data to all nodes.
!
      CALL mpi_bcast (a, npts, mp_float, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# endif
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 70, __line__, myfile)
# endif
!
 10   FORMAT (/,' MP_ASSEMBLEF_1D - inconsistent array size, Npts = ',  &
     &        i10,2x,i10,/,19x,'number of addressed array elements ',   &
     &        'is incorrect.')
 20   FORMAT (/,' MP_ASSEMBLEF_1D - illegal special value, Aspv = ',    &
     &        1p,e17.10,/,19x,'a zero value is needed for global ',     &
     &        'reduction.')
 30   FORMAT (/,' MP_ASSEMBLEF_1D - error during ',a,' call, Task = ',  &
     &        i3.3,' Error = ',i3,/,19x,a)
!
      RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::master, mod_parallel::mp_float, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:

mp_assemblef_2d()

subroutine distribute_mod::mp_assemble::mp_assemblef_2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	npts,
		real(r8), intent(in)	aspv,
		real(r8), dimension(:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 2516 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine assembles a 2D floating-point array from all members   !
!  in the group.  The collection of data from all nodes is achieved    !
!  as a reduction sum.                                                 !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Npts       Number of collected data points, PROD(SIZE(A)).       !
!     Aspv       Special value indicating that an array element is     !
!                  not operated by the current parallel node. It must  !
!                  be zero to collect data by a global reduction sum.  !
!     A          2D array to collect.                                  !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Assembled 2D array.                                   !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Npts
 
      integer, intent(in), optional :: InpComm
!
      real(r8), intent(in) :: Aspv
 
      real(r8), intent(inout) :: A(:,:)
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, MyNpts, Nnodes, Serror
      integer :: i, rank, request
 
      integer :: Asize(2)
 
      integer, dimension(MPI_STATUS_SIZE) :: status
!
# if defined ASSEMBLE_ALLGATHER
      real(r8), dimension(Npts,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
      real(r8), dimension(Npts) :: Asend
# elif defined ASSEMBLE_ALLREDUCE
      real(r8), dimension(Npts) :: Arecv, Asend
# elif defined ASSEMBLE_SENDRECV
      real(r8), allocatable :: Arecv(:)
      real(r8), dimension(Npts) :: Asend
# endif
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_assemblef_2d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 70, __line__, myfile)
# endif
# ifdef MPI
!
!-----------------------------------------------------------------------
!  Set distributed-memory communicator handle (context ID).
!-----------------------------------------------------------------------
!
      IF (PRESENT(inpcomm)) THEN
        mycomm=inpcomm
      ELSE
        mycomm=ocn_comm_world
      END IF
# endif
!
!-----------------------------------------------------------------------
!  Check input parameters.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
# if defined ASSEMBLE_ALLGATHER
      bmemmax(ng)=max(bmemmax(ng), real((npts+SIZE(arecv))*kind(a),r8))
# else
      bmemmax(ng)=max(bmemmax(ng), real(2*npts*kind(a),r8))
# endif
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      mynpts=asize(1)*asize(2)
      IF (npts.ne.mynpts) THEN
        IF (master) THEN
          WRITE (stdout,10) npts, mynpts
        END IF
        exit_flag=7
      END IF
!
      IF (aspv.ne.0.0_r8) THEN
        IF (master) THEN
          WRITE (stdout,20) aspv
        END IF
        exit_flag=7
      END IF
!
!-----------------------------------------------------------------------
!  Collect data from all nodes.
!-----------------------------------------------------------------------
!
!  Reshape input 2D data into 1D array to facilitate communications.
!
      asend=reshape(a, (/npts/))
 
# if defined ASSEMBLE_ALLGATHER
!
!  Collect data from all nodes.
!
      CALL mpi_allgather (asend, npts, mp_float, arecv, npts, mp_float, &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  Pack data according to special values: sum or ignore.
!
      nnodes=ntilei(ng)*ntilej(ng)-1
      IF (aspv.eq.0.0_r8) THEN
        DO i=1,npts
          asend(i)=0.0_r8
          DO rank=0,nnodes
            asend(i)=asend(i)+arecv(i,rank)
          END DO
        END DO
      ELSE
        DO i=1,npts
          DO rank=0,nnodes
            IF (arecv(i,rank).ne.aspv) THEN
              asend(i)=arecv(i,rank)
            END IF
          END DO
        END DO
      END IF
!
!  Load collected data in output 2D array.
!
      a=reshape(asend, asize)
 
# elif defined ASSEMBLE_ALLREDUCE
!
!  Collect data from all nodes as a reduced sum.
!
      CALL mpi_allreduce (asend, arecv, npts, mp_float, mpi_sum,        &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_ALLREDUCE', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  Load collected data into output 2D array.
!
      a=reshape(arecv, asize)
 
# elif defined ASSEMBLE_SENDRECV
!
      IF (myrank.eq.mymaster) THEN
!
!  If master node, allocate and receive buffer.
!
        IF (.not.allocated(arecv)) THEN
          allocate (arecv(npts))
        END IF
!
!  If master node, loop over other nodes to receive and accumulate the
!  data.
!
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_irecv (arecv, npts, mp_float, rank, rank+5,          &
     &                    mycomm, request, myerror)
          CALL mpi_wait (request, status, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,30) 'MPI_IRECV', rank, myerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
          DO i=1,npts
            asend(i)=asend(i)+arecv(i)
          END DO
        END DO
        deallocate (arecv)
!
!  Load collected data in output 2D array.
!
        a=reshape(asend, asize)
!
!  Otherwise, send data to master node.
!
      ELSE
        CALL mpi_isend (asend, npts, mp_float, mymaster, myrank+5,      &
     &                  mycomm, request, myerror)
        CALL mpi_wait (request, status, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,30) 'MPI_ISEND', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast accumulated (full) data to all nodes.
!
      CALL mpi_bcast (a, npts, mp_float, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 70, __line__, myfile)
# endif
!
 10   FORMAT (/,' MP_ASSEMBLEF_2D - inconsistent array size, Npts = ',  &
     &        i10,2x,i10,/,19x,'number of addressed array elements ',   &
     &        'is incorrect.')
 20   FORMAT (/,' MP_ASSEMBLEF_2D - illegal special value, Aspv = ',    &
     &        1p,e17.10,/,19x,'a zero value is needed for global ',     &
     &        'reduction.')
 30   FORMAT (/,' MP_ASSEMBLEF_2D - error during ',a,' call, Task = ',  &
     &        i3.3,' Error = ',i3,/,19x,a)
!
      RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::master, mod_parallel::mp_float, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:

mp_assemblef_3d()

subroutine distribute_mod::mp_assemble::mp_assemblef_3d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	npts,
		real(r8), intent(in)	aspv,
		real(r8), dimension(:,:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 2772 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine assembles a 3D floating-point array from all members   !
!  in the group.  The collection of data from all nodes is achieved    !
!  as a reduction sum.                                                 !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Npts       Number of collected data points, PROD(SIZE(A)).       !
!     Aspv       Special value indicating that an array element is     !
!                  not operated by the current parallel node. It must  !
!                  be zero to collect data by a global reduction sum.  !
!     A          3D array to collect.                                  !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Assembled 3D array.                                   !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Npts
 
      integer, intent(in), optional :: InpComm
 
      real(r8), intent(in) :: Aspv
 
      real(r8), intent(inout) :: A(:,:,:)
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, MyNpts, Nnodes, Serror
      integer :: i, rank, request
 
      integer :: Asize(3)
 
      integer, dimension(MPI_STATUS_SIZE) :: status
!
# if defined ASSEMBLE_ALLGATHER
      real(r8), dimension(Npts,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
      real(r8), dimension(Npts) :: Asend
# elif defined ASSEMBLE_ALLREDUCE
      real(r8), dimension(Npts) :: Arecv, Asend
# elif defined ASSEMBLE_SENDRECV
      real(r8), allocatable :: Arecv(:)
      real(r8), dimension(Npts) :: Asend
# endif
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_assemblef_3d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 70, __line__, myfile)
# endif
# ifdef MPI
!
!-----------------------------------------------------------------------
!  Set distributed-memory communicator handle (context ID).
!-----------------------------------------------------------------------
!
      IF (PRESENT(inpcomm)) THEN
        mycomm=inpcomm
      ELSE
        mycomm=ocn_comm_world
      END IF
# endif
!
!-----------------------------------------------------------------------
!  Check input parameters.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
# if defined ASSEMBLE_ALLGATHER
      bmemmax(ng)=max(bmemmax(ng), real((npts+SIZE(arecv))*kind(a),r8))
# else
      bmemmax(ng)=max(bmemmax(ng), real(2*npts*kind(a),r8))
# endif
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      asize(3)=ubound(a, dim=3)
      mynpts=asize(1)*asize(2)*asize(3)
      IF (npts.ne.mynpts) THEN
        IF (master) THEN
          WRITE (stdout,10) npts, mynpts
        END IF
        exit_flag=7
      END IF
!
      IF (aspv.ne.0.0_r8) THEN
        IF (master) THEN
          WRITE (stdout,20) aspv
        END IF
        exit_flag=7
      END IF
!
!-----------------------------------------------------------------------
!  Collect data from all nodes.
!-----------------------------------------------------------------------
!
!  Reshape input 3D data into 1D array to facilitate communications.
!
      asend=reshape(a, (/npts/))
 
# if defined ASSEMBLE_ALLGATHER
!
!  Collect data from all nodes.
!
      CALL mpi_allgather (asend, npts, mp_float, arecv, npts, mp_float, &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  Pack data according to special values: sum or ignore.
!
      nnodes=ntilei(ng)*ntilej(ng)-1
      IF (aspv.eq.0.0_r8) THEN
        DO i=1,npts
          asend(i)=0.0_r8
          DO rank=0,nnodes
            asend(i)=asend(i)+arecv(i,rank)
          END DO
        END DO
      ELSE
        DO i=1,npts
          DO rank=0,nnodes
            IF (arecv(i,rank).ne.aspv) THEN
              asend(i)=arecv(i,rank)
            END IF
          END DO
        END DO
      END IF
!
!  Load collected data into output 3D array.
!
      a=reshape(asend, asize)
 
# elif defined ASSEMBLE_ALLREDUCE
!
!  Collect data from all nodes as a reduced sum.
!
      CALL mpi_allreduce (asend, arecv, npts, mp_float, mpi_sum,        &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_ALLREDUCE', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  Load collected data into output 3D array.
!
      a=reshape(arecv, asize)
 
# elif defined ASSEMBLE_SENDRECV
!
      IF (myrank.eq.mymaster) THEN
!
!  If master node, allocate and receive buffer.
!
        IF (.not.allocated(arecv)) THEN
          allocate (arecv(npts))
        END IF
!
!  If master node, loop over other nodes to receive and accumulate the
!  data.
!
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_irecv (arecv, npts, mp_float, rank, rank+5,          &
     &                    mycomm, request, myerror)
          CALL mpi_wait (request, status, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,30) 'MPI_IRECV', rank, myerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
          DO i=1,npts
            asend(i)=asend(i)+arecv(i)
          END DO
        END DO
        deallocate (arecv)
!
!  Load collected data into output 3D array.
!
        a=reshape(asend, asize)
!
!  Otherwise, send data to master node.
!
      ELSE
        CALL mpi_isend (asend, npts, mp_float, mymaster, myrank+5,      &
     &                  mycomm, request, myerror)
        CALL mpi_wait (request, status, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,30) 'MPI_ISEND', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast accumulated (full) data to all nodes.
!
      CALL mpi_bcast (a, npts, mp_float, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 70, __line__, myfile)
# endif
!
 10   FORMAT (/,' MP_ASSEMBLEF_3D - inconsistent array size, Npts = ',  &
     &        i10,2x,i10,/,19x,'number of addressed array elements ',   &
     &        'is incorrect.')
 20   FORMAT (/,' MP_ASSEMBLEF_3D - illegal special value, Aspv = ',    &
     &        1p,e17.10,/,19x,'a zero value is needed for global ',     &
     &        'reduction.')
 30   FORMAT (/,' MP_ASSEMBLEF_3D - error during ',a,' call, Task = ',  &
     &        i3.3,' Error = ',i3,/,19x,a)
!
      RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::master, mod_parallel::mp_float, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:

mp_assemblei_1d()

subroutine distribute_mod::mp_assemble::mp_assemblei_1d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	npts,
		integer, intent(in)	aspv,
		integer, dimension(:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 3029 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine assembles a 1D integer array from all members in the   !
!  group.  The collection of data from all nodes is achieved as a      !
!  reduction sum.                                                      !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Npts       Number of collected data points, PROD(SIZE(A)).       !
!     Aspv       Special value indicating that an array element is     !
!                  not operated by the current parallel node. It must  !
!                  be zero to collect data by a global reduction sum.  !
!     A          1D array to collect.                                  !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Assembled 1D array.                                   !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Npts
 
      integer, intent(in), optional :: InpComm
 
      integer, intent(in) :: Aspv
 
      integer, intent(inout) :: A(:)
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, MyNpts, Nnodes, Serror
      integer :: i, rank, request
 
      integer, dimension(MPI_STATUS_SIZE) :: status
 
# if defined ASSEMBLE_ALLGATHER
      integer, dimension(Npts,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
# elif defined ASSEMBLE_ALLREDUCE
      integer, dimension(Npts) :: Asend
# elif defined ASSEMBLE_SENDRECV
      integer, allocatable :: Arecv(:)
# endif
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_assemblei_1d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 70, __line__, myfile)
# endif
# ifdef MPI
!
!-----------------------------------------------------------------------
!  Set distributed-memory communicator handle (context ID).
!-----------------------------------------------------------------------
!
      IF (PRESENT(inpcomm)) THEN
        mycomm=inpcomm
      ELSE
        mycomm=ocn_comm_world
      END IF
# endif
!
!-----------------------------------------------------------------------
!  Check input parameters.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
# if defined ASSEMBLE_ALLGATHER
      bmemmax(ng)=max(bmemmax(ng), real(SIZE(arecv)*kind(a),r8))
# else
      bmemmax(ng)=max(bmemmax(ng), real(npts*kind(a),r8))
# endif
!
      mynpts=ubound(a, dim=1)
      IF (npts.ne.mynpts) THEN
        IF (master) THEN
          WRITE (stdout,10) npts, mynpts
        END IF
        exit_flag=7
      END IF
!
      IF (aspv.ne.0) THEN
        IF (master) THEN
          WRITE (stdout,20) aspv
        END IF
        exit_flag=7
      END IF
!
!-----------------------------------------------------------------------
!  Collect data from all nodes.
!-----------------------------------------------------------------------
!
# if defined ASSEMBLE_ALLGATHER
      CALL mpi_allgather (a, npts, mpi_integer,                         &
     &                    arecv, npts, mpi_integer,                     &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  Pack data according to special values: sum or ignore.
!
      nnodes=ntilei(ng)*ntilej(ng)-1
      IF (aspv.eq.0.0_r8) THEN
        DO i=1,npts
          a(i)=0.0_r8
          DO rank=0,nnodes
            a(i)=a(i)+arecv(i,rank)
          END DO
        END DO
      ELSE
        DO i=1,npts
          DO rank=0,nnodes
            IF (arecv(i,rank).ne.aspv) THEN
              a(i)=arecv(i,rank)
            END IF
          END DO
        END DO
      END IF
 
# elif defined ASSEMBLE_ALLREDUCE
!
!  Copy data to send.
!
      DO i=1,npts
        asend(i)=a(i)
      END DO
!
!  Collect data from all nodes as a reduced sum.
!
      CALL mpi_allreduce (asend, a, npts, mpi_integer, mpi_sum,         &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_ALLREDUCE', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
 
# elif defined ASSEMBLE_SENDRECV
 
      IF (myrank.eq.mymaster) THEN
!
!  If master node, allocate and receive buffer.
!
        IF (.not.allocated(arecv)) THEN
          allocate (arecv(npts))
        END IF
!
!  If master node, loop over other nodes to receive and accumulate the
!  data.
!
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_irecv (arecv, npts, mpi_integer, rank, rank+5,       &
     &                    mycomm, request, myerror)
          CALL mpi_wait (request, status, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,30) 'MPI_IRECV', rank, myerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
          DO i=1,npts
            a(i)=a(i)+arecv(i)
          END DO
        END DO
        deallocate (arecv)
!
!  Otherwise, send data to master node.
!
      ELSE
        CALL mpi_isend (a, npts, mpi_integer, mymaster, myrank+5,       &
     &                  mycomm, request, myerror)
        CALL mpi_wait (request, status, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,30) 'MPI_ISEND', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast accumulated (full) data to all nodes.
!
      CALL mpi_bcast (a, npts, mpi_integer, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 70, __line__, myfile)
# endif
!
 10   FORMAT (/,' MP_ASSEMBLEI_1D - inconsistent array size, Npts = ',  &
     &        i10,2x,i10,/,19x,'number of addressed array elements ',   &
     &        'is incorrect.')
 20   FORMAT (/,' MP_ASSEMBLEI_1D - illegal special value, Aspv = ',i4, &
     &        /,19x,'a zero value is needed for global reduction.')
 30   FORMAT (/,' MP_ASSEMBLEI_1D - error during ',a,' call, Task = ',  &
     &        i3.3,' Error = ',i3,/,19x,a)
!
      RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::master, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:

mp_assemblei_2d()

subroutine distribute_mod::mp_assemble::mp_assemblei_2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	npts,
		integer, intent(in)	aspv,
		integer, dimension(:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 3266 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine assembles a 2D integer array from all members in the   !
!  group.  The collection of data from all nodes is achieved as a      !
!  reduction sum.                                                      !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Npts       Number of collected data points, PROD(SIZE(A)).       !
!     Aspv       Special value indicating that an array element is     !
!                  not operated by the current parallel node. It must  !
!                  be zero to collect data by a global reduction sum.  !
!     A          2D array to collect.                                  !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Assembled 2D array.                                   !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Npts
 
      integer, intent(in), optional :: InpComm
 
      integer, intent(in) :: Aspv
 
      integer, intent(inout) :: A(:,:)
!
!  Local variable declarations.
!
      integer :: Lstr,  MyCOMM, MyError, MyNpts, Nnodes, Serror
      integer :: i, rank, request
 
      integer :: Asize(2)
 
      integer, dimension(MPI_STATUS_SIZE) :: status
 
# if defined ASSEMBLE_ALLGATHER
      integer, dimension(Npts,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
      integer, dimension(Npts) :: Asend
# elif defined ASSEMBLE_ALLREDUCE
      integer, dimension(Npts) :: Arecv, Asend
# elif defined ASSEMBLE_SENDRECV
      integer, allocatable :: Arecv(:)
      integer, dimension(Npts) :: Asend
# endif
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_assemblei_2d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 70, __line__, myfile)
# endif
# ifdef MPI
!
!-----------------------------------------------------------------------
!  Set distributed-memory communicator handle (context ID).
!-----------------------------------------------------------------------
!
      IF (PRESENT(inpcomm)) THEN
        mycomm=inpcomm
      ELSE
        mycomm=ocn_comm_world
      END IF
# endif
!
!-----------------------------------------------------------------------
!  Check input parameters.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
# if defined ASSEMBLE_ALLGATHER
      bmemmax(ng)=max(bmemmax(ng), real((npts+SIZE(arecv))*kind(a),r8))
# else
      bmemmax(ng)=max(bmemmax(ng), real(2*npts*kind(a),r8))
# endif
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      mynpts=asize(1)*asize(2)
      IF (npts.ne.mynpts) THEN
        IF (master) THEN
          WRITE (stdout,10) npts, mynpts
        END IF
        exit_flag=7
      END IF
!
      IF (aspv.ne.0) THEN
        IF (master) THEN
          WRITE (stdout,20) aspv
        END IF
        exit_flag=7
      END IF
!
!-----------------------------------------------------------------------
!  Collect data from all nodes.
!-----------------------------------------------------------------------
!
!  Reshape input 2D data into 1D array to facilitate communications.
!
      asend=reshape(a, (/npts/))
 
# if defined ASSEMBLE_ALLGATHER
!
!  Collect data from all nodes.
!
      CALL mpi_allgather (asend, npts, mpi_integer,                     &
     &                    arecv, npts, mpi_integer,                     &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  Pack data according to special values: sum or ignore.
!
      nnodes=ntilei(ng)*ntilej(ng)-1
      IF (aspv.eq.0.0_r8) THEN
        DO i=1,npts
          asend(i)=0.0_r8
          DO rank=0,nnodes
            asend(i)=asend(i)+arecv(i,rank)
          END DO
        END DO
      ELSE
        DO i=1,npts
          DO rank=0,nnodes
            IF (arecv(i,rank).ne.aspv) THEN
              asend(i)=arecv(i,rank)
            END IF
          END DO
        END DO
      END IF
!
!  Load collected data in output 2D array.
!
      a=reshape(asend, asize)
 
# elif defined ASSEMBLE_ALLREDUCE
!
!  Collect data from all nodes as a reduced sum.
!
      CALL mpi_allreduce (asend, arecv, npts, mpi_integer, mpi_sum,     &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_ALLREDUCE', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  Load collected data.
!
      a=reshape(arecv, asize)
 
# elif defined ASSEMBLE_SENDRECV
!
      IF (myrank.eq.mymaster) THEN
!
!  If master node, allocate and receive buffer.
!
        IF (.not.allocated(arecv)) THEN
          allocate (arecv(npts))
        END IF
!
!  If master node, loop over other nodes to receive and accumulate the
!  data.
!
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_irecv (arecv, npts, mpi_integer, rank, rank+5,       &
     &                    mycomm, request, myerror)
          CALL mpi_wait (request, status, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,30) 'MPI_IRECV', rank, myerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
          DO i=1,npts
            asend(i)=asend(i)+arecv(i)
          END DO
        END DO
        deallocate (arecv)
!
!  Load collected data in output 2D array.
!
        a=reshape(asend, asize)
!
!  Otherwise, send data to master node.
!
      ELSE
        CALL mpi_isend (asend, npts, mpi_integer, mymaster, myrank+5,   &
     &                  mycomm, request, myerror)
        CALL mpi_wait (request, status, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,30) 'MPI_ISEND', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast accumulated (full) data to all nodes.
!
      CALL mpi_bcast (a, npts, mpi_integer, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,30) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 70, __line__, myfile)
# endif
!
 10   FORMAT (/,' MP_ASSEMBLEI_2D - inconsistent array size, Npts = ',  &
     &        i10,2x,i10,/,19x,'number of addressed array elements ',   &
     &        'is incorrect.')
 20   FORMAT (/,' MP_ASSEMBLEI_2D - illegal special value, Aspv = ',i4, &
     &        /,19x,'a zero value is needed for global reduction.')
 30   FORMAT (/,' MP_ASSEMBLEI_2D - error during ',a,' call, Task = ',  &
     &        i3.3,' Error = ',i3,/,19x,a)
!
      RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, mod_parallel::master, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:

---

The documentation for this interface was generated from the following file:

• ROMS/Utility/distribute.F