distribute_mod Module Reference

Data Types
interface	mp_assemble
interface	mp_bcastf
interface	mp_bcasti
interface	mp_bcastl
interface	mp_bcasts
interface	mp_collect
interface	mp_reduce

Functions/Subroutines
subroutine	mp_barrier (ng, model, inpcomm)
subroutine	mp_bcastf_0dp (ng, model, a, inpcomm)
subroutine	mp_bcastf_1dp (ng, model, a, inpcomm)
subroutine	mp_bcastf_2dp (ng, model, a, inpcomm)
subroutine	mp_bcastf_3dp (ng, model, a, inpcomm)
subroutine	mp_bcastf_0d (ng, model, a, inpcomm)
subroutine	mp_bcastf_1d (ng, model, a, inpcomm)
subroutine	mp_bcastf_2d (ng, model, a, inpcomm)
subroutine	mp_bcastf_3d (ng, model, a, inpcomm)
subroutine	mp_bcastf_4d (ng, model, a, inpcomm)
subroutine	mp_bcasti_0d (ng, model, a, inpcomm)
subroutine	mp_bcasti_1d (ng, model, a, inpcomm)
subroutine	mp_bcasti_2d (ng, model, a, inpcomm)
subroutine	mp_bcastl_0d (ng, model, a, inpcomm)
subroutine	mp_bcastl_1d (ng, model, a, inpcomm)
subroutine	mp_bcastl_2d (ng, model, a, inpcomm)
subroutine	mp_bcasts_0d (ng, model, a, inpcomm)
subroutine	mp_bcasts_1d (ng, model, a, inpcomm)
subroutine	mp_bcasts_2d (ng, model, a, inpcomm)
subroutine	mp_bcasts_3d (ng, model, a, inpcomm)
subroutine	mp_bcast_struc (ng, model, s, inpcomm)
subroutine	mp_boundary (ng, model, imin, imax, lbi, ubi, lbk, ubk, update, a)
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)
subroutine	mp_collect_f (ng, model, npts, aspv, a, inpcomm)
subroutine	mp_collect_i (ng, model, npts, aspv, a, inpcomm)
subroutine	mp_gather2d (ng, model, lbi, ubi, lbj, ubj, tindex, gtype, ascl, amask, a, npts, awrk, setfillval)
subroutine	mp_gather3d (ng, model, lbi, ubi, lbj, ubj, lbk, ubk, tindex, gtype, ascl, amask, a, npts, awrk, setfillval)
subroutine	mp_gather_state (ng, model, mstr, mend, asize, a, awrk)
integer function	mp_ncread1d (ng, model, ncid, ncvname, ncname, ncrec, lb1, ub1, ascale, a)
integer function	mp_ncread2d (ng, model, ncid, ncvname, ncname, ncrec, lb1, ub1, lb2, ub2, ascale, a)
integer function	mp_ncwrite1d (ng, model, ncid, ncvname, ncname, ncrec, lb1, ub1, ascale, a)
integer function	mp_ncwrite2d (ng, model, ncid, ncvname, ncname, ncrec, lb1, ub1, lb2, ub2, ascale, a)
subroutine	mp_reduce_i8 (ng, model, asize, a, handle_op, inpcomm)
subroutine	mp_reduce_0dp (ng, model, asize, a, handle_op, inpcomm)
subroutine	mp_reduce_1dp (ng, model, asize, a, handle_op, inpcomm)
subroutine	mp_reduce_0d (ng, model, asize, a, handle_op, inpcomm)
subroutine	mp_reduce_1d (ng, model, asize, a, handle_op, inpcomm)
subroutine	mp_reduce2 (ng, model, isize, jsize, a, handle_op, inpcomm)
subroutine	mp_scatter2d (ng, model, lbi, ubi, lbj, ubj, nghost, gtype, amin, amax, nwpts, ij_water, npts, a, awrk)
subroutine	mp_scatter3d (ng, model, lbi, ubi, lbj, ubj, lbk, ubk, nghost, gtype, amin, amax, nwpts, ij_water, npts, a, awrk)
subroutine	mp_scatter_state (ng, model, mstr, mend, asize, a, awrk)
subroutine	mp_aggregate2d (ng, model, gtype, lbit, ubit, lbjt, ubjt, lbig, ubig, lbjg, ubjg, atiled, aglobal)
subroutine	mp_aggregate3d (ng, model, gtype, lbit, ubit, lbjt, ubjt, lbig, ubig, lbjg, ubjg, lbk, ubk, atiled, aglobal)
subroutine	mp_dump (ng, tile, gtype, ilb, iub, jlb, jub, klb, kub, a, name)

Function/Subroutine Documentation

mp_aggregate2d()

subroutine distribute_mod::mp_aggregate2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	gtype,
		integer, intent(in)	lbit,
		integer, intent(in)	ubit,
		integer, intent(in)	lbjt,
		integer, intent(in)	ubjt,
		integer, intent(in)	lbig,
		integer, intent(in)	ubig,
		integer, intent(in)	lbjg,
		integer, intent(in)	ubjg,
		real(r8), dimension(lbit:ubit,lbjt:ubjt), intent(in)	atiled,
		real(r8), dimension(lbig:ubig,lbjg:ubjg), intent(out)	aglobal )

Definition at line 8661 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects a 2D tiled, floating-point array from each    !
!  spawned node and stores it into 2D global array. If nesting, the    !
!  global array contains the contact points data.                      !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     gtype      C-grid type.                                          !
!     LBiT       Tiled  array, I-dimension Lower bound.                !
!     UBiT       Tiled  array, I-dimension Upper bound.                !
!     LBjT       Tiled  array, J-dimension Lower bound.                !
!     UBjT       Tiled  array, J-dimension Upper bound.                !
!     LBiG       Global array, I-dimension Lower bound.                !
!     UBiG       Global array, I-dimension Upper bound.                !
!     LBjG       Global array, J-dimension Lower bound.                !
!     UBjG       Global array, J-dimension Upper bound.                !
!     Atiled     2D tiled, floating-point array to process.            !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Aglobal    2D global array, all tiles are aggregated.            !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, gtype
      integer, intent(in) :: LBiT, UBiT, LBjT, UBjT
      integer, intent(in) :: LBiG, UBiG, LBjG, UBjG
!
      real(r8), intent(in)  :: Atiled(LBiT:UBiT,LBjT:UBjT)
      real(r8), intent(out) :: Aglobal(LBiG:UBiG,LBjG:UBjG)
!
!  Local variable declarations.
!
      integer :: Lstr, MyError, MyType, Nnodes, Npts, Serror
      integer :: i, j, np, rank
 
      integer,  dimension(4,0:NtileI(ng)*NtileJ(ng)-1) :: my_bounds
!
      real(r8), dimension(TileSize(ng)) :: Asend
      real(r8), dimension(TileSize(ng)*                                 &
     &                    NtileI(ng)*NtileJ(ng)) :: Arecv
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_aggregate2d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 71, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Set horizontal starting and ending indices for parallel domain
!  partitions in the XI- and ETA-directions.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real((SIZE(asend)+                   &
     &                                   SIZE(aglobal)+                 &
     &                                   SIZE(arecv))*kind(asend),r8))
!
!  Number of nodes in the group.
!
      nnodes=ntilei(ng)*ntilej(ng)-1
!
!  Set starting and ending indices to process including contact points
!  (if nesting) according to the staggered C-grid classification.
!
      mytype=abs(gtype)
 
      SELECT CASE (mytype)
        CASE (p2dvar, p3dvar)
          DO rank=0,nnodes
            my_bounds(1,rank)=bounds(ng) % IstrP(rank)
            my_bounds(2,rank)=bounds(ng) % IendP(rank)
            my_bounds(3,rank)=bounds(ng) % JstrP(rank)
            my_bounds(4,rank)=bounds(ng) % JendP(rank)
          END DO
        CASE (r2dvar, r3dvar)
          DO rank=0,nnodes
            my_bounds(1,rank)=bounds(ng) % IstrT(rank)
            my_bounds(2,rank)=bounds(ng) % IendT(rank)
            my_bounds(3,rank)=bounds(ng) % JstrT(rank)
            my_bounds(4,rank)=bounds(ng) % JendT(rank)
          END DO
        CASE (u2dvar, u3dvar)
          DO rank=0,nnodes
            my_bounds(1,rank)=bounds(ng) % IstrP(rank)
            my_bounds(2,rank)=bounds(ng) % IendP(rank)
            my_bounds(3,rank)=bounds(ng) % JstrT(rank)
            my_bounds(4,rank)=bounds(ng) % JendT(rank)
          END DO
        CASE (v2dvar, v3dvar)
          DO rank=0,nnodes
            my_bounds(1,rank)=bounds(ng) % IstrT(rank)
            my_bounds(2,rank)=bounds(ng) % IendT(rank)
            my_bounds(3,rank)=bounds(ng) % JstrP(rank)
            my_bounds(4,rank)=bounds(ng) % JendP(rank)
          END DO
      END SELECT
!
!  Determine the maximum number of points to process between all tiles.
!  In collective communications, the amount of data sent must be equal
!  to the amount of data received.
!
      npts=0
      DO rank=0,nnodes
        np=(my_bounds(2,rank)-my_bounds(1,rank)+1)*                     &
     &     (my_bounds(4,rank)-my_bounds(3,rank)+1)
        npts=max(npts, np)
      END DO
 
      IF (npts.gt.tilesize(ng)) THEN
        IF (master) THEN
          WRITE (stdout,10) ' TileSize = ', tilesize(ng), npts
 10       FORMAT (/,' MP_AGGREGATE2D - communication buffer to small,', &
     &            a, 2i8)
        END IF
        exit_flag=5
        RETURN
      END IF
!
!  Initialize local arrays to facilitate collective communicatios.
!  This also avoid denormalized values, which facilitates debugging.
!
      asend=0.0_r8
      arecv=0.0_r8
!
!-----------------------------------------------------------------------
!  Pack tile data.
!-----------------------------------------------------------------------
!
      np=0
      DO j=my_bounds(3,myrank),my_bounds(4,myrank)
        DO i=my_bounds(1,myrank),my_bounds(2,myrank)
          np=np+1
          asend(np)=atiled(i,j)
        END DO
      END DO
!
!-----------------------------------------------------------------------
!  Aggregate data from all nodes.
!-----------------------------------------------------------------------
!
      CALL mpi_allgather (asend, npts, mp_float,                        &
     &                    arecv, npts, mp_float,                        &
     &                    ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,20) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
 20     FORMAT (/,' MP_AGGREGATE2D - error during ',a,' call, Task = ', &
     &          i3.3,' Error = ',i3,/,18x,a)
        exit_flag=5
        RETURN
      END IF
!
!-----------------------------------------------------------------------
!  Unpack data into a global 2D array.
!-----------------------------------------------------------------------
!
      DO rank=0,nnodes
        np=rank*npts
        DO j=my_bounds(3,rank),my_bounds(4,rank)
          DO i=my_bounds(1,rank),my_bounds(2,rank)
            np=np+1
            aglobal(i,j)=arecv(np)
          END DO
        END DO
      END DO
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 71, __line__, myfile)
# endif
!
      RETURN
 

References mod_param::bmemmax, mod_param::bounds, mod_scalars::exit_flag, mod_parallel::master, mod_parallel::mp_float, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_param::p2dvar, mod_param::p3dvar, mod_param::r2dvar, mod_param::r3dvar, mod_iounits::stdout, mod_param::tilesize, mod_param::u2dvar, mod_param::u3dvar, mod_param::v2dvar, mod_param::v3dvar, wclock_off(), and wclock_on().

Referenced by ad_nesting_mod::ad_fine2coarse2d(), ad_nesting_mod::ad_fine2coarse3d(), nesting_mod::fine2coarse2d(), and nesting_mod::fine2coarse3d().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_aggregate3d()

subroutine distribute_mod::mp_aggregate3d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	gtype,
		integer, intent(in)	lbit,
		integer, intent(in)	ubit,
		integer, intent(in)	lbjt,
		integer, intent(in)	ubjt,
		integer, intent(in)	lbig,
		integer, intent(in)	ubig,
		integer, intent(in)	lbjg,
		integer, intent(in)	ubjg,
		integer, intent(in)	lbk,
		integer, intent(in)	ubk,
		real(r8), dimension(lbit:ubit,lbjt:ubjt,lbk:ubk), intent(in)	atiled,
		real(r8), dimension(lbig:ubig,lbjg:ubjg,lbk:ubk), intent(out)	aglobal )

Definition at line 8861 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects a 3D tiled, floating-point array from each    !
!  spawned node and stores it into 3D global array. If nesting, the    !
!  global array contains the contact points data.                      !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     gtype      C-grid type.                                          !
!     LBiT       Tiled  array, I-dimension Lower bound.                !
!     UBiT       Tiled  array, I-dimension Upper bound.                !
!     LBjT       Tiled  array, J-dimension Lower bound.                !
!     UBjT       Tiled  array, J-dimension Upper bound.                !
!     LBkT       Tiled  array, K-dimension Lower bound.                !
!     UBkT       Tiled  array, K-dimension Upper bound.                !
!     LBiG       Global array, I-dimension Lower bound.                !
!     UBiG       Global array, I-dimension Upper bound.                !
!     LBjG       Global array, J-dimension Lower bound.                !
!     UBjG       Global array, J-dimension Upper bound.                !
!     LBkG       Global array, K-dimension Lower bound.                !
!     UBkG       Global array, K-dimension Upper bound.                !
!     Atiled     3D tiled, floating-point array to process.            !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Aglobal    3D global array, all tiles are aggregated.            !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, gtype
      integer, intent(in) :: LBiT, UBiT, LBjT, UBjT
      integer, intent(in) :: LBiG, UBiG, LBjG, UBjG
      integer, intent(in) :: LBk,  UBk
!
      real(r8), intent(in)  :: Atiled(LBiT:UBiT,LBjT:UBjT,LBk:UBk)
      real(r8), intent(out) :: Aglobal(LBiG:UBiG,LBjG:UBjG,LBk:UBk)
!
!  Local variable declarations.
!
      integer :: Klen, Lstr, MyError, MyType, Nnodes, Npts, Serror
      integer :: i, j, k, np, rank
 
      integer,  dimension(4,0:NtileI(ng)*NtileJ(ng)-1) :: my_bounds
!
      real(r8), dimension(TileSize(ng)*(UBk-LBk+1)) :: Asend
 
      real(r8), dimension(TileSize(ng)*(UBk-LBk+1)*                     &
     &                    NtileI(ng)*NtileJ(ng)) :: Arecv
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_aggregate3d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 71, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Set horizontal starting and ending indices for parallel domain
!  partitions in the XI- and ETA-directions.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real((SIZE(asend)+                   &
     &                                   SIZE(aglobal)+                 &
     &                                   SIZE(arecv))*kind(asend),r8))
!
!  Number of nodes in the group.
!
      nnodes=ntilei(ng)*ntilej(ng)-1
!
!  Set starting and ending indices to process including contact points
!  (if nesting) according to the staggered C-grid classification.
!
      mytype=abs(gtype)
 
      SELECT CASE (mytype)
        CASE (p2dvar, p3dvar)
          DO rank=0,nnodes
            my_bounds(1,rank)=bounds(ng) % IstrP(rank)
            my_bounds(2,rank)=bounds(ng) % IendP(rank)
            my_bounds(3,rank)=bounds(ng) % JstrP(rank)
            my_bounds(4,rank)=bounds(ng) % JendP(rank)
          END DO
        CASE (r2dvar, r3dvar)
          DO rank=0,nnodes
            my_bounds(1,rank)=bounds(ng) % IstrT(rank)
            my_bounds(2,rank)=bounds(ng) % IendT(rank)
            my_bounds(3,rank)=bounds(ng) % JstrT(rank)
            my_bounds(4,rank)=bounds(ng) % JendT(rank)
          END DO
        CASE (u2dvar, u3dvar)
          DO rank=0,nnodes
            my_bounds(1,rank)=bounds(ng) % IstrP(rank)
            my_bounds(2,rank)=bounds(ng) % IendP(rank)
            my_bounds(3,rank)=bounds(ng) % JstrT(rank)
            my_bounds(4,rank)=bounds(ng) % JendT(rank)
          END DO
        CASE (v2dvar, v3dvar)
          DO rank=0,nnodes
            my_bounds(1,rank)=bounds(ng) % IstrT(rank)
            my_bounds(2,rank)=bounds(ng) % IendT(rank)
            my_bounds(3,rank)=bounds(ng) % JstrP(rank)
            my_bounds(4,rank)=bounds(ng) % JendP(rank)
          END DO
      END SELECT
      klen=ubk-lbk+1
!
!  Determine the maximum number of points to process between all tiles.
!  In collective communications, the amount of data sent must be equal
!  to the amount of data received.
!
      npts=0
      DO rank=0,nnodes
        np=(my_bounds(2,rank)-my_bounds(1,rank)+1)*                     &
     &     (my_bounds(4,rank)-my_bounds(3,rank)+1)*                     &
     &     klen
        npts=max(npts, np)
      END DO
 
      IF (npts.gt.tilesize(ng)*klen) THEN
        IF (master) THEN
          WRITE (stdout,10) ' TileSize = ', tilesize(ng)*klen, npts
 10       FORMAT (/,' MP_AGGREGATE3D - communication buffer to small,', &
     &            a, 2i8)
        END IF
        exit_flag=5
        RETURN
      END IF
!
!  Initialize local arrays to facilitate collective communicatios.
!  This also avoid denormalized values, which facilitates debugging.
!
      asend=0.0_r8
      arecv=0.0_r8
!
!-----------------------------------------------------------------------
!  Pack tile data.
!-----------------------------------------------------------------------
!
      np=0
      DO k=lbk,ubk
        DO j=my_bounds(3,myrank),my_bounds(4,myrank)
          DO i=my_bounds(1,myrank),my_bounds(2,myrank)
            np=np+1
            asend(np)=atiled(i,j,k)
          END DO
        END DO
      END DO
!
!-----------------------------------------------------------------------
!  Aggregate data from all nodes.
!-----------------------------------------------------------------------
!
      CALL mpi_allgather (asend, npts, mp_float,                        &
     &                    arecv, npts, mp_float,                        &
     &                    ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,20) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
 20     FORMAT (/,' MP_AGGREGATE3D - error during ',a,' call, Task = ', &
     &          i3.3,' Error = ',i3,/,18x,a)
        exit_flag=5
        RETURN
      END IF
!
!-----------------------------------------------------------------------
!  Unpack data into a global 2D array.
!-----------------------------------------------------------------------
!
      DO rank=0,nnodes
        np=rank*npts
        DO k=lbk,ubk
          DO j=my_bounds(3,rank),my_bounds(4,rank)
            DO i=my_bounds(1,rank),my_bounds(2,rank)
              np=np+1
              aglobal(i,j,k)=arecv(np)
            END DO
          END DO
        END DO
      END DO
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 71, __line__, myfile)
# endif
!
      RETURN
 

References mod_param::bmemmax, mod_param::bounds, mod_scalars::exit_flag, mod_parallel::master, mod_parallel::mp_float, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_param::p2dvar, mod_param::p3dvar, mod_param::r2dvar, mod_param::r3dvar, mod_iounits::stdout, mod_param::tilesize, mod_param::u2dvar, mod_param::u3dvar, mod_param::v2dvar, mod_param::v3dvar, wclock_off(), and wclock_on().

Referenced by ad_nesting_mod::ad_fine2coarse3d(), and nesting_mod::fine2coarse3d().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_assemblef_1d()

subroutine distribute_mod::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

mp_assemblef_2d()

subroutine distribute_mod::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

mp_assemblef_3d()

subroutine distribute_mod::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

mp_assemblei_1d()

subroutine distribute_mod::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

mp_assemblei_2d()

subroutine distribute_mod::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

mp_barrier()

subroutine distribute_mod::mp_barrier	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in), optional	inpcomm )

Definition at line 125 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine blocks the caller until all group members have called  !
!  it.                                                                 !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
!  Local variable declarations.
!
      integer ::  MyCOMM, MyError
!
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_barrier"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 72, __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
!
!-----------------------------------------------------------------------
!  Synchronize all distribute-memory nodes in the group.
!-----------------------------------------------------------------------
!
# ifdef MPI
      CALL mpi_barrier (mycomm, myerror)
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 72, __line__, myfile)
# endif
!
      RETURN

References mod_parallel::ocn_comm_world, wclock_off(), and wclock_on().

Referenced by strings_mod::globalerror(), strings_mod::taskerror(), wclock_off(), and wclock_on().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_bcast_struc()

subroutine distribute_mod::mp_bcast_struc	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		type(t_io), dimension(:), intent(inout)	s,
		integer, intent(in), optional	inpcomm )

Definition at line 1923 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts the NetCDF IDs of a TYPE_IO structure to    !
!  all processors in the communicator. It is called by all the         !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     S          ROMS I/O structure, TYPE(T_IO).                       !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     S          Broadcasted ROMS I/O structure.                       !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      TYPE(T_IO), intent(inout) :: S(:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Nchars, Npts, Serror
      integer :: ibuffer(5)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcast_struc"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast variables in structure.
!-----------------------------------------------------------------------
 
# ifdef MPI
!
!  Structure scalar integer variables.
!
      ibuffer(1)=s(ng)%Nfiles
      ibuffer(2)=s(ng)%Fcount
      ibuffer(3)=s(ng)%load
      ibuffer(4)=s(ng)%Rindex
      ibuffer(5)=s(ng)%ncid
!
      npts=5
      CALL mpi_bcast (ibuffer, 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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCAST_STRUC - error during ',a,' call, Task = ', &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      ELSE
        s(ng)%Nfiles=ibuffer(1)
        s(ng)%Fcount=ibuffer(2)
        s(ng)%load  =ibuffer(3)
        s(ng)%Rindex=ibuffer(4)
        s(ng)%ncid  =ibuffer(5)
      END IF
!
!  Variables IDs.
!
      npts=ubound(s(ng)%Vid, dim=1)
      CALL mpi_bcast (s(ng)%Vid, 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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
 
#  ifdef SOLVE3D
!
!  Tracer variables IDs.
!
      npts=ubound(s(ng)%Tid, dim=1)
      CALL mpi_bcast (s(ng)%Tid, 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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
#  endif
!
!  Structure Filenames.
!
      nchars=len(s(ng)%head)
      CALL mpi_bcast (s(ng)%head, nchars, mpi_byte, mymaster,           &
     &                mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
      nchars=len(s(ng)%base)
      CALL mpi_bcast (s(ng)%base, nchars, mpi_byte, mymaster,           &
     &                mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
      nchars=len(s(ng)%name)
      CALL mpi_bcast (s(ng)%name, nchars, mpi_byte, mymaster,           &
     &                mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
      nchars=len(s(ng)%files(1))*s(ng)%Nfiles
      CALL mpi_bcast (s(ng)%files, nchars, mpi_byte, mymaster,          &
     &                mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) '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, 64, __line__, myfile)
# endif
!
      RETURN

References mod_scalars::exit_flag, mod_parallel::mymaster, mod_parallel::myrank, mod_parallel::ocn_comm_world, mod_iounits::stdout, wclock_off(), and wclock_on().

Here is the call graph for this function:

mp_bcastf_0d()

subroutine distribute_mod::mp_bcastf_0d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		real(r8), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 560 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a floating-point scalar variable to all     !
!  processors in the communicator. It is called by all the members     !
!  in the group.                                                       !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          Variable to broadcast (real).                         !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted variable.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      real(r8), intent(inout) :: A
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastf_0d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      npts=1
# ifdef MPI
      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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTF_0D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcastf_0dp()

subroutine distribute_mod::mp_bcastf_0dp	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		real(dp), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 195 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a double-precision scalar variable to all   !
!  processors in the communicator. It is called by all the members in  !
!  the group.                                                          !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          Variable to broadcast (real).                         !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted variable.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
 
      real(dp), intent(inout) :: A
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastf_0dp"
 
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      npts=1
#  ifdef MPI
      CALL mpi_bcast (a, npts, mp_double, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTF_0DP - error during ',a,' call, Task = ',  &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
#  endif
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
#  endif
!
      RETURN

mp_bcastf_1d()

subroutine distribute_mod::mp_bcastf_1d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		real(r8), dimension(:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 648 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 1D floating-point, non-tiled, array       !
!  to all processors in the communicator. It is called by all the      !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          1D array to broadcast (real).                         !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 1D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      real(r8), intent(inout) :: A(:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastf_1d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      npts=ubound(a, dim=1)
 
# ifdef MPI
      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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTF_1D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcastf_1dp()

subroutine distribute_mod::mp_bcastf_1dp	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		real(dp), dimension(:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 283 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 1D double-precission, non-tiled, array    !
!  to all processors in the communicator. It is called by all the      !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          1D array to broadcast (real).                         !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 1D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      real(dp), intent(inout) :: A(:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastf_1dp"
 
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      npts=ubound(a, dim=1)
 
#  ifdef MPI
      CALL mpi_bcast (a, npts, mp_double, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTF_1DP - error during ',a,' call, Task = ',  &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
#  endif
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
#  endif
!
      RETURN

mp_bcastf_2d()

subroutine distribute_mod::mp_bcastf_2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		real(r8), dimension(:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 737 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 2D floating-point, non-tiled, array       !
!  to all processors in the communicator. It is called by all the      !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          2D array to broadcast (real).                         !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 2D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      real(r8), intent(inout) :: A(:,:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
 
      integer :: Asize(2)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastf_2d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      npts=asize(1)*asize(2)
 
# ifdef MPI
      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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTF_2D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcastf_2dp()

subroutine distribute_mod::mp_bcastf_2dp	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		real(dp), dimension(:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 372 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 2D double-preision, non-tiled, array      !
!  to all processors in the communicator. It is called by all the      !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          2D array to broadcast (real).                         !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 2D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      real(dp), intent(inout) :: A(:,:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
 
      integer :: Asize(2)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastf_2dp"
 
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      npts=asize(1)*asize(2)
 
#  ifdef MPI
      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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTF_2DP - error during ',a,' call, Task = ',  &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
#  endif
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
#  endif
!
      RETURN

mp_bcastf_3d()

subroutine distribute_mod::mp_bcastf_3d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		real(r8), dimension(:,:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 830 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 3D floating-point, non-tiled, array       !
!  to all processors in the communicator. It is called by all the      !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          3D array to broadcast (real).                         !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 3D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      real(r8), intent(inout) :: A(:,:,:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
 
      integer :: Asize(3)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastf_3d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      asize(3)=ubound(a, dim=3)
      npts=asize(1)*asize(2)*asize(3)
 
# ifdef MPI
      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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTF_3D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcastf_3dp()

subroutine distribute_mod::mp_bcastf_3dp	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		real(dp), dimension(:,:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 465 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 3D double-precision, non-tiled, array     !
!  to all processors in the communicator. It is called by all the      !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          3D array to broadcast (real).                         !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 3D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      real(dp), intent(inout) :: A(:,:,:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
 
      integer :: Asize(3)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastf_3d"
 
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      asize(3)=ubound(a, dim=3)
      npts=asize(1)*asize(2)*asize(3)
 
#  ifdef MPI
      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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTF_3DP - error during ',a,' call, Task = ',  &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
#  endif
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
#  endif
!
      RETURN

mp_bcastf_4d()

subroutine distribute_mod::mp_bcastf_4d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		real(r8), dimension(:,:,:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 924 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 4D floating-point, non-tiled, array       !
!  to all processors in the communicator. It is called by all the      !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          4D array to broadcast (real).                         !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 4D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      real(r8), intent(inout) :: A(:,:,:,:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
 
      integer :: Asize(4)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastf_4d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      asize(3)=ubound(a, dim=3)
      asize(4)=ubound(a, dim=4)
      npts=asize(1)*asize(2)*asize(3)*asize(4)
 
# ifdef MPI
      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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTF_4D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcasti_0d()

subroutine distribute_mod::mp_bcasti_0d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 1018 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts an integer scalar variable to all           !
!  processors in the communicator.  It is called by all the            !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          Variable to broadcast (integer).                      !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted variable.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
 
      integer, intent(inout) :: A
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcasti_0d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      IF (lwclock) THEN
        CALL wclock_on (ng, model, 64, __line__, myfile)
      END IF
# endif
# ifdef MPI
!
!-----------------------------------------------------------------------
!  Set distributed-memory communicator handle (context ID).
!-----------------------------------------------------------------------
!
      IF (PRESENT(inpcomm)) THEN
        mycomm=inpcomm
      ELSE
        mycomm=ocn_comm_world
      END IF
# endif
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      npts=1
# ifdef MPI
      CALL mpi_bcast (a, npts, mpi_integer, mymaster, ocn_comm_world,   &
     &                myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTI_0D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      IF (lwclock) THEN
        CALL wclock_off (ng, model, 64, __line__, myfile)
      END IF
# endif
!
      RETURN

mp_bcasti_1d()

subroutine distribute_mod::mp_bcasti_1d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, dimension(:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 1110 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 1D non-tiled, integer array to all        !
!  processors in the communicator. It is called by all the             !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          1D array to broadcast (integer).                      !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 1D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
 
      integer, intent(inout) :: A(:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcasti_1d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      npts=ubound(a, dim=1)
 
# ifdef MPI
      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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTI_1D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcasti_2d()

subroutine distribute_mod::mp_bcasti_2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, dimension(:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 1199 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 2D non-tiled, integer array to all        !
!  processors in the communicator. It is called by all the             !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          2D array to broadcast (integer).                      !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 2D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
 
      integer, intent(inout) :: A(:,:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
      integer :: Asize(2)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcasti_2d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      npts=asize(1)*asize(2)
 
# ifdef MPI
      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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTI_2D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcastl_0d()

subroutine distribute_mod::mp_bcastl_0d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		logical, intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 1291 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a logical scalar variable to all            !
!  processors in the communicator. It is called by all the             !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          Variable to broadcast (logical).                      !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted variable.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      logical, intent(inout) :: A
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastl_0d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      npts=1
# ifdef MPI
      CALL mpi_bcast (a, npts, mpi_logical, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTL_0D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcastl_1d()

subroutine distribute_mod::mp_bcastl_1d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		logical, dimension(:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 1379 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 1D nontiled, logical array to all         !
!  processors in the communicator. It is called by all the             !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          1D array to broadcast (logical).                      !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 1D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      logical, intent(inout) :: A(:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastl_1d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      npts=ubound(a, dim=1)
 
# ifdef MPI
      CALL mpi_bcast (a, npts, mpi_logical, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTL_1D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcastl_2d()

subroutine distribute_mod::mp_bcastl_2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		logical, dimension(:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 1468 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 2D non-tiled, logical array to all        !
!  processors in the communicator. It is called by all the             !
!  members in the group.                                               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          2D array to broadcast (logical).                      !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 2D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      logical, intent(inout) :: A(:,:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
      integer :: Asize(2)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcastl_2d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      npts=asize(1)*asize(2)
 
# ifdef MPI
      CALL mpi_bcast (a, npts, mpi_logical, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTL_2D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcasts_0d()

subroutine distribute_mod::mp_bcasts_0d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		character (len=*), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 1560 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a string scalar variable to all processors  !
!  in the communicator. It is called by all the members in the group.  !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          Variable to broadcast (string).                       !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted variable.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      character (len=*), intent(inout) :: A
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Nchars, Serror
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcasts_0d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      IF (lwclock) THEN
        CALL wclock_on (ng, model, 64, __line__, myfile)
      END IF
# endif
# ifdef MPI
!
!-----------------------------------------------------------------------
!  Set distributed-memory communicator handle (context ID).
!-----------------------------------------------------------------------
!
      IF (PRESENT(inpcomm)) THEN
        mycomm=inpcomm
      ELSE
        mycomm=ocn_comm_world
      END IF
# endif
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      nchars=len(a)
# ifdef MPI
      CALL mpi_bcast (a, nchars, mpi_byte, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTS_0D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      IF (lwclock) THEN
        CALL wclock_off (ng, model, 64, __line__, myfile)
      END IF
# endif
!
      RETURN

mp_bcasts_1d()

subroutine distribute_mod::mp_bcasts_1d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		character (len=*), dimension(:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 1651 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 1D string array to all processors in the  !
!  communicator. It is called by all the members in the group.         !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          1D array to broadcast (string).                       !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 1D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      character (len=*), intent(inout) :: A(:)
!
!  Local variable declarations
!
      integer :: Asize, Lstr, MyCOMM, MyError, Nchars, Serror
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcasts_1d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      asize=ubound(a, dim=1)
      nchars=len(a(1))*asize
 
# ifdef MPI
      CALL mpi_bcast (a, nchars, mpi_byte, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTS_1D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcasts_2d()

subroutine distribute_mod::mp_bcasts_2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		character (len=*), dimension(:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 1740 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 2D string array to all processors in the  !
!  communicator. It is called by all the members in the group.         !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          2D array to broadcast (string).                       !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 2D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      character (len=*), intent(inout) :: A(:,:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Nchars, Serror
      integer :: Asize(2)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcasts_2d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      nchars=len(a(1,1))*asize(1)*asize(2)
 
# ifdef MPI
      CALL mpi_bcast (a, nchars, mpi_byte, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTS_2D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_bcasts_3d()

subroutine distribute_mod::mp_bcasts_3d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		character (len=*), dimension(:,:,:), intent(inout)	a,
		integer, intent(in), optional	inpcomm )

Definition at line 1831 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts a 3D string array to all processors in the  !
!  communicator. It is called by all the members in the group.         !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     A          3D array to broadcast (string).                       !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Broadcasted 3D array.                                 !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
 
      integer, intent(in), optional :: InpComm
!
      character (len=*), intent(inout) :: A(:,:,:)
!
!  Local variable declarations
!
      integer :: Lstr, MyCOMM, MyError, Nchars, Serror
      integer :: Asize(3)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_bcasts_3d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 64, __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
!
!-----------------------------------------------------------------------
!  Broadcast requested variable.
!-----------------------------------------------------------------------
!
      asize(1)=ubound(a, dim=1)
      asize(2)=ubound(a, dim=2)
      asize(3)=ubound(a, dim=3)
      nchars=len(a(1,1,1))*asize(1)*asize(2)*asize(3)
 
# ifdef MPI
      CALL mpi_bcast (a, nchars, mpi_byte, mymaster, mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
 10     FORMAT (/,' MP_BCASTS_3D - error during ',a,' call, Task = ',   &
     &          i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 64, __line__, myfile)
# endif
!
      RETURN

mp_boundary()

subroutine distribute_mod::mp_boundary	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	imin,
		integer, intent(in)	imax,
		integer, intent(in)	lbi,
		integer, intent(in)	ubi,
		integer, intent(in)	lbk,
		integer, intent(in)	ubk,
		logical, intent(in)	update,
		real(r8), dimension(lbi:ubi,lbk:ubk), intent(inout)	a )

Definition at line 2103 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine exchanges boundary arrays between tiles.               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Imin       Starting tile index.                                  !
!     Imax       Ending   tile index.                                  !
!     Jstr       Starting tile index in the J-direction.               !
!     Jend       Ending   tile index in the J-direction.               !
!     LBi        I-dimension Lower bound.                              !
!     UBi        I-dimension Upper bound.                              !
!     LBk        K-dimension Lower bound, if any. Otherwise, a value   !
!                  of one is expected.                                 !
!     LBk        K-dimension Upper bound, if any. Otherwise, a value   !
!                  of one is expected.                                 !
!     UBk        K-dimension Upper bound.                              !
!     update     Switch activated by the node that updated the         !
!                  boundary data.                                      !
!     A          Boundary array (1D or 2D) to process.                 !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Updated boundary array (1D or 2D).                    !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      logical, intent(in) :: update
!
      integer, intent(in) :: ng, model, Imin, Imax
      integer, intent(in) :: LBi, UBi, LBk, UBk
!
      real(r8), intent(inout) :: A(LBi:UBi,LBk:UBk)
!
!  Local variable declarations.
!
      integer :: Ilen, Ioff, Lstr, MyError, Nnodes, Npts, Serror
      integer :: i, ik, k, kc, rank
!
      real(r8), dimension((UBi-LBi+1)*(UBk-LBk+1)) :: Asend
 
# if defined BOUNDARY_ALLGATHER
      real(r8), dimension((UBi-LBi+1)*(UBk-LBk+1),                      &
     &                    0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
# elif defined BOUNDARY_ALLREDUCE
      real(r8), dimension((UBi-LBi+1)*(UBk-LBk+1)) :: Arecv
# endif
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_boundary"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 68, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Pack boundary data.  Zero-out boundary array except points updated
!  by the appropriate node, so sum reduction can be perfomed during
!  unpacking.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real((SIZE(asend)+                   &
     &                                   SIZE(arecv))*kind(a),r8))
!
!  Initialize buffer to the full range so unpacking is correct with
!  summation.  This also allows even exchange of segments with
!  communication routine "mpi_allgather".
!
      ilen=ubi-lbi+1
      ioff=1-lbi
      npts=ilen*(ubk-lbk+1)
      DO i=1,npts
        asend(i)=0.0_r8
      END DO
!
!  If a boundary tile, load boundary data.
!
      IF (update) THEN
        DO k=lbk,ubk
          kc=(k-lbk)*ilen
          DO i=imin,imax
            ik=i+ioff+kc
            asend(ik)=a(i,k)
          END DO
        END DO
      END IF
!
!-----------------------------------------------------------------------
!  Collect data from all nodes.
!-----------------------------------------------------------------------
!
# ifdef MPI
#  if defined BOUNDARY_ALLGATHER
      CALL mpi_allgather (asend, npts, mp_float, arecv, npts, mp_float, &
     &                    ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
 10     FORMAT (/,' MP_BOUNDARY - error during ',a,' call, Task = ',    &
     &          i3.3,' Error = ',i3,/,15x,a)
        exit_flag=2
        RETURN
      END IF
#  elif defined BOUNDARY_ALLREDUCE
      CALL mpi_allreduce (asend, arecv, npts, mp_float, mpi_sum,        &
     &                    ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror,             &
     &                    string(1:lstr)
 10     FORMAT (/,' MP_BOUNDARY - error during ',a,' call, Task = ',    &
     &          i3.3,' Error = ',i3,/,15x,a)
        exit_flag=2
        RETURN
      END IF
#  endif
# endif
!
!-----------------------------------------------------------------------
!  Unpack data: reduction sum.
!-----------------------------------------------------------------------
!
# if defined BOUNDARY_ALLGATHER
      nnodes=ntilei(ng)*ntilej(ng)-1
      ik=0
      DO k=lbk,ubk
        DO i=lbi,ubi
          a(i,k)=0.0_r8
          ik=ik+1
          DO rank=0,nnodes
            a(i,k)=a(i,k)+arecv(ik,rank)
          END DO
        END DO
      END DO
# elif defined BOUNDARY_ALLREDUCE
      ik=0
      DO k=lbk,ubk
        DO i=lbi,ubi
          ik=ik+1
          a(i,k)=arecv(ik)
        END DO
      END DO
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 68, __line__, myfile)
# endif
!
      RETURN
 

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

Referenced by ad_set_data_tile(), rp_set_data_tile(), set_data_tile(), set_tides_mod::set_tides_tile(), and tl_set_data_tile().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_collect_f()

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

Definition at line 3522 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects a 1D floating-point array from all members    !
!  in the group. Then, it packs distributed data by removing the       !
!  special values. This routine is used when extracting station        !
!  data from tiled arrays.                                             !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Npts       Number of collected data points.                      !
!     Aspv       Special value indicating no data.  This implies that  !
!                  desired data is tile unbouded.                      !
!     A          Collected data.                                       !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Collected data.                                       !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Npts
 
      integer, intent(in), optional :: InpComm
!
      real(r8), intent(in) :: Aspv
 
      real(r8), intent(inout) :: A(Npts)
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, Nnodes, Serror
      integer :: i, rank, request
 
      integer, dimension(MPI_STATUS_SIZE) :: status
!
# if defined COLLECT_ALLGATHER
      real(r8), dimension(Npts,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
# elif defined COLLECT_ALLREDUCE
      real(r8), dimension(Npts) :: Asend
# else
      real(r8), allocatable :: Arecv(:)
# endif
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_collect_f"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 69, __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
!
!-----------------------------------------------------------------------
!  Collect data from all nodes.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
# if defined COLLECT_ALLGATHER
      bmemmax(ng)=max(bmemmax(ng), real(SIZE(arecv)*kind(a),r8))
# else
      bmemmax(ng)=max(bmemmax(ng), real(npts*kind(a),r8))
# endif
 
# if defined COLLECT_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,10) '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 COLLECT_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, 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,10) 'MPI_ALLREDUCE', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# else
!
      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,10) '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,10) '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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# endif
 10   FORMAT (/,' MP_COLLECT_F - error during ',a,' call, Task = ',     &
     &        i3.3,' Error = ',i3,/,14x,a)
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 69, __line__, myfile)
# endif
!
      RETURN

mp_collect_i()

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

Definition at line 3733 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects a 1D integer array from all members in        !
!  the group. Then, it packs distributed data by removing the          !
!  special values. This routine is used when extracting station        !
!  data from tiled arrays.                                             !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Npts       Number of collected data points.                      !
!     Aspv       Special value indicating no data.  This implies that  !
!                  desired data is tile unbouded.                      !
!     A          Collected data.                                       !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Collected data.                                       !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Npts
 
      integer, intent(in) :: Aspv
 
      integer, intent(in), optional :: InpComm
 
      integer, intent(inout) :: A(Npts)
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, Nnodes, Serror
      integer :: i, rank, request
 
      integer, dimension(MPI_STATUS_SIZE) :: status
 
# if defined COLLECT_ALLGATHER
      integer, dimension(Npts,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
# elif defined COLLECT_ALLREDUCE
      integer, dimension(Npts) :: Asend
# else
      integer, allocatable :: Arecv(:)
# endif
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_collect_i"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 69, __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
!
!-----------------------------------------------------------------------
!  Collect data from all nodes.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
# if defined COLLECT_ALLGATHER
      bmemmax(ng)=max(bmemmax(ng), real(SIZE(arecv)*kind(a),r8))
# else
      bmemmax(ng)=max(bmemmax(ng), real(npts*kind(a),r8))
# endif
 
# if defined COLLECT_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,10) '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) THEN
        DO i=1,npts
          a(i)=0
          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 COLLECT_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,10) 'MPI_ALLREDUCE', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# else
!
      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,10) '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,10) '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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# endif
 10   FORMAT (/,' MP_COLLECT_I - error during ',a,' call, Task = ',     &
     &        i3.3,' Error = ',i3,/,14x,a)
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 69, __line__, myfile)
# endif
!
      RETURN

mp_dump()

subroutine distribute_mod::mp_dump	(	integer, intent(in)	ng,
		integer, intent(in)	tile,
		integer, intent(in)	gtype,
		integer, intent(in)	ilb,
		integer, intent(in)	iub,
		integer, intent(in)	jlb,
		integer, intent(in)	jub,
		integer, intent(in)	klb,
		integer, intent(in)	kub,
		real(r8), dimension(ilb:iub,jlb:jub,klb:kub), intent(in)	a,
		character (len=*)	name )

Definition at line 9074 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine is used to debug distributed-memory communications.    !
!  It writes field into an ASCII file for further post-processing.     !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, tile, gtype
      integer, intent(in) :: ILB, IUB, JLB, JUB, KLB, KUB
!
      real(r8), intent(in) :: A(ILB:IUB,JLB:JUB,KLB:KUB)
!
      character (len=*) :: name
!
!  Local variable declarations.
!
      common /counter/ nc
      integer :: nc
!
      logical, save :: first = .true.
!
      integer :: Imin, Imax, Ioff, Jmin, Jmax, Joff
      integer :: unit
!
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_dump"
 
# include "set_bounds.h"
!
!------------------------------------------------------------------------
!  Write out requested field.
!------------------------------------------------------------------------
!
      IF (first) THEN
        nc=0
        first=.false.
      END IF
      nc=nc+1
      IF (master) THEN
        WRITE (10,'(a,i3.3,a,a)') 'file ', nc, ': ', trim(name)
        FLUSH (10)
      END IF
!
!  Write out field including ghost-points.
!
      imin=0
      imax=lm(ng)+1
      IF (ewperiodic(ng)) THEN
        ioff=3
      ELSE
        ioff=1
      END IF
 
      jmin=0
      jmax=mm(ng)+1
      IF (nsperiodic(ng)) THEN
        joff=3
      ELSE
        joff=1
      END IF
 
      IF ((gtype.eq.p2dvar).or.(gtype.eq.p3dvar).or.                    &
     &    (gtype.eq.u2dvar).or.(gtype.eq.u3dvar)) THEN
        imin=1
      END IF
      IF ((gtype.eq.p2dvar).or.(gtype.eq.p3dvar).or.                    &
     &    (gtype.eq.v2dvar).or.(gtype.eq.v3dvar)) THEN
        jmin=1
      END IF
 
      unit=(myrank+1)*1000+nc
      WRITE (unit,*) ilb, iub, jlb, jub, klb, kub,                      &
     &               ioff, joff, imin, imax, jmin, jmax,                &
     &               a(ilb:iub,jlb:jub,klb:kub)
      FLUSH (unit)
!
!  Write out non-overlapping field.
!
      imin=istrr
      imax=iendr
      IF (ewperiodic(ng)) THEN
        ioff=2
      ELSE
        ioff=1
      END IF
 
      jmin=jstrr
      jmax=jendr
      IF (nsperiodic(ng)) THEN
        joff=2
      ELSE
        joff=1
      END IF
 
      IF ((gtype.eq.p2dvar).or.(gtype.eq.p3dvar).or.                    &
     &    (gtype.eq.u2dvar).or.(gtype.eq.u3dvar)) THEN
        imin=istr
        ioff=ioff-1
      END IF
      IF ((gtype.eq.p2dvar).or.(gtype.eq.p3dvar).or.                    &
     &    (gtype.eq.v2dvar).or.(gtype.eq.v3dvar)) THEN
        jmin=jstr
        joff=joff-1
      END IF
 
      unit=(myrank+1)*10000+nc
      WRITE (unit,*) imin, imax, jmin, jmax, klb, kub,                  &
     &               ioff, joff, imin, imax, jmin, jmax,                &
     &               a(imin:imax,jmin:jmax,klb:kub)
      FLUSH (unit)
 
      RETURN

References mod_scalars::ewperiodic, mod_param::lm, mod_parallel::master, mod_param::mm, mod_parallel::myrank, mod_scalars::nsperiodic, mod_param::p2dvar, mod_param::p3dvar, mod_param::u2dvar, mod_param::u3dvar, mod_param::v2dvar, and mod_param::v3dvar.

mp_gather2d()

subroutine distribute_mod::mp_gather2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	lbi,
		integer, intent(in)	ubi,
		integer, intent(in)	lbj,
		integer, intent(in)	ubj,
		integer, intent(in)	tindex,
		integer, intent(in)	gtype,
		real(dp), intent(in)	ascl,
		real(r8), dimension(lbi:ubi,lbj:ubj), intent(in)	amask,
		real(r8), dimension(lbi:ubi,lbj:ubj), intent(in)	a,
		integer, intent(out)	npts,
		real(r8), dimension(:), intent(out)	awrk,
		logical, intent(in), optional	setfillval )

Definition at line 3944 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects a 2D tiled, floating-point array from each    !
!  spawned node and stores it into one dimensional global array. It    !
!  is used to collect and  pack output data.                           !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     LBi        I-dimension Lower bound.                              !
!     UBi        I-dimension Upper bound.                              !
!     LBj        J-dimension Lower bound.                              !
!     UBj        J-dimension Upper bound.                              !
!     tindex     Time record index to process.                         !
!     gtype      C-grid type. If negative and Land-Sea is available,   !
!                  only water-points processed.                        !
!     Ascl       Factor to scale field before writing.                 !
!     Amask      Land/Sea mask, if any.                                !
!     A          2D tiled, floating-point array to process.            !
!     SetFillVal Logical switch to set fill value in land areas        !
!                  (optional).                                         !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Npts       Number of points processed in Awrk.                   !
!     Awrk       Collected data from each node packed into 1D array    !
!                  in column-major order. That is, in the same way     !
!                  that Fortran multi-dimensional arrays are stored    !
!                  in memory.                                          !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      logical, intent(in), optional :: SetFillVal
!
      integer, intent(in) :: ng, model, tindex, gtype
      integer, intent(in) :: LBi, UBi, LBj, UBj
      integer, intent(out) :: Npts
!
      real(dp), intent(in) :: Ascl
 
# ifdef MASKING
      real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
# endif
      real(r8), intent(in)  :: A(LBi:UBi,LBj:UBj)
      real(r8), intent(out) :: Awrk(:)
!
!  Local variable declarations.
!
# ifdef MASKING
      logical :: LandFill
# endif
      integer :: Cgrid, Ntasks, ghost, rank
      integer :: Io, Ie, Jo, Je, Ioff, Joff
      integer :: Imin, Imax, Jmin, Jmax
      integer :: iLB, iUB, jLB, jUB
      integer :: Asize, Isize, Jsize, IJsize
      integer :: Lstr, MyError, MyType, Serror, Srequest
      integer :: i, ic, ij, j, jc, nc
!
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: counts, displs
# ifdef GATHER_SENDRECV
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: MySize
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
 
      integer, dimension(MPI_STATUS_SIZE) :: Rstatus
      integer, dimension(MPI_STATUS_SIZE) :: Sstatus
!
      real(r8), allocatable :: Arecv(:,:)
# else
      real(r8), allocatable :: Arecv(:)
# endif
      real(r8), allocatable :: Asend(:)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_gather2d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 66, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Set horizontal starting and ending indices for parallel domain
!  partitions in the XI- and ETA-directions.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real(tilesize(ng)*kind(a),r8))
!
!  Set full grid first and last point according to staggered C-grid
!  classification. Notice that the offsets are for the private array
!  counter.
!
      mytype=abs(gtype)
 
      SELECT CASE (mytype)
        CASE (p2dvar, p3dvar)
          io=iobounds(ng) % ILB_psi
          ie=iobounds(ng) % IUB_psi
          jo=iobounds(ng) % JLB_psi
          je=iobounds(ng) % JUB_psi
          ioff=0
          joff=1
        CASE (r2dvar, r3dvar)
          io=iobounds(ng) % ILB_rho
          ie=iobounds(ng) % IUB_rho
          jo=iobounds(ng) % JLB_rho
          je=iobounds(ng) % JUB_rho
          ioff=1
          joff=0
        CASE (u2dvar, u3dvar)
          io=iobounds(ng) % ILB_u
          ie=iobounds(ng) % IUB_u
          jo=iobounds(ng) % JLB_u
          je=iobounds(ng) % JUB_u
          ioff=0
          joff=0
        CASE (v2dvar, v3dvar)
          io=iobounds(ng) % ILB_v
          ie=iobounds(ng) % IUB_v
          jo=iobounds(ng) % JLB_v
          je=iobounds(ng) % JUB_v
          ioff=1
          joff=1
        CASE DEFAULT                              ! RHO-points
          io=iobounds(ng) % ILB_rho
          ie=iobounds(ng) % IUB_rho
          jo=iobounds(ng) % JLB_rho
          je=iobounds(ng) % JUB_rho
          ioff=1
          joff=0
      END SELECT
!
      isize=ie-io+1
      jsize=je-jo+1
      ijsize=isize*jsize
      npts=isize*jsize
!
!  Set "GATHERV" counts and displacement vectors. Use non-overlapping
!  (ghost=0) ranges according to tile rank.
!
      ghost=0
!
      SELECT CASE (mytype)
        CASE (p2dvar, p3dvar)
          cgrid=1
        CASE (r2dvar, r3dvar)
          cgrid=2
        CASE (u2dvar, u3dvar)
          cgrid=3
        CASE (v2dvar, v3dvar)
          cgrid=4
        CASE DEFAULT                              ! RHO-points
          cgrid=2
      END SELECT
!
      ntasks=ntilei(ng)*ntilej(ng)
      nc=0
      DO rank=0,ntasks-1
        ilb=bounds(ng) % Imin(cgrid,ghost,rank)
        iub=bounds(ng) % Imax(cgrid,ghost,rank)
        jlb=bounds(ng) % Jmin(cgrid,ghost,rank)
        jub=bounds(ng) % Jmax(cgrid,ghost,rank)
# ifdef GATHER_SENDRECV
        mysize(rank)=(iub-ilb+1)*(jub-jlb+1)
# endif
        displs(rank)=nc
        DO j=jlb,jub
          DO i=ilb,iub
            nc=nc+1
          END DO
        END DO
        counts(rank)=nc-displs(rank)
      END DO
!
!-----------------------------------------------------------------------
!  Pack and scale input tiled data.
!-----------------------------------------------------------------------
!
      imin=bounds(ng) % Imin(cgrid,ghost,myrank)
      imax=bounds(ng) % Imax(cgrid,ghost,myrank)
      jmin=bounds(ng) % Jmin(cgrid,ghost,myrank)
      jmax=bounds(ng) % Jmax(cgrid,ghost,myrank)
!
      asize=(imax-imin+1)*(jmax-jmin+1)
      allocate ( asend(asize) )
      asend=0.0_r8
!
      nc=0
      DO j=jmin,jmax
        DO i=imin,imax
          nc=nc+1
          asend(nc)=a(i,j)*ascl
        END DO
      END DO
 
# ifdef MASKING
!
!  If overwriting Land/Sea mask or processing water-points only, flag
!  land-points with special value.
!
      IF (PRESENT(setfillval)) THEN
        landfill=setfillval
      ELSE
        landfill=tindex.gt.0
      END IF
      IF (gtype.lt.0) THEN
        nc=0
        DO j=jmin,jmax
          DO i=imin,imax
            nc=nc+1
            IF (amask(i,j).eq.0.0_r8) THEN
              asend(nc)=spval
            END IF
          END DO
        END DO
      ELSE IF (landfill) THEN
        nc=0
        DO j=jmin,jmax
          DO i=imin,imax
            nc=nc+1
            IF (amask(i,j).eq.0.0_r8) THEN
              asend(nc)=spval
            END IF
          END DO
        END DO
      END IF
# endif
!
!-----------------------------------------------------------------------
!  Gather requested global data from tiled arrays.
!-----------------------------------------------------------------------
 
# ifdef GATHER_SENDRECV
!
      allocate ( arecv(ijsize, ntasks-1) )
      arecv=0.0_r8
!
!  If master processor, unpack the send buffer since there is not
!  need to distribute.
!
      IF (myrank.eq.mymaster) THEN
        nc=0
        DO j=jmin,jmax
          jc=(j-joff)*isize
          DO i=imin,imax
            nc=nc+1
            ic=i+ioff+jc
            awrk(ic)=asend(nc)
          END DO
        END DO
      END IF
!
!  Send, receive, and unpack data.
!
      IF (myrank.eq.mymaster) THEN
        DO rank=1,ntasks-1
          CALL mpi_irecv (arecv(1,rank), mysize(rank), mp_float, rank,  &
     &                    rank+5, ocn_comm_world, rrequest(rank),       &
     &                    myerror)
        END DO
        DO rank=1,ntasks-1
          CALL mpi_wait (rrequest(rank), rstatus, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,10) 'MPI_IRECV', rank, myerror, string(1:lstr)
 10         FORMAT (/,' MP_GATHER2D - error during ',a,                 &
     &              ' call, Task = ',i3.3,' Error = ',i3,/,13x,a)
            exit_flag=2
            RETURN
          END IF
!
          imin=bounds(ng) % Imin(cgrid,ghost,rank)
          imax=bounds(ng) % Imax(cgrid,ghost,rank)
          jmin=bounds(ng) % Jmin(cgrid,ghost,rank)
          jmax=bounds(ng) % Jmax(cgrid,ghost,rank)
!
          nc=0
          DO j=jmin,jmax
            jc=(j-joff)*isize
            DO i=imin,imax
              nc=nc+1
              ic=i+ioff+jc
              awrk(ic)=arecv(nc,rank)
            END DO
          END DO
        END DO
      ELSE
        CALL mpi_isend (asend, asize, mp_float, mymaster,               &
     &                  myrank+5, ocn_comm_world, srequest, myerror)
        CALL mpi_wait (srequest, sstatus, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ISEND', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
 
# else
!
!  Gather local tiled data into a global array.
!
      allocate ( arecv(ijsize) )
      arecv=0.0_r8
!
      CALL mpi_gatherv (asend, asize, mp_float,                         &
     &                  arecv, counts, displs, mp_float,                &
     &                  mymaster, ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        WRITE (stdout,10) 'MPI_GATHERV', myrank, myerror, trim(string)
 10     FORMAT (/,' MP_GATHER2D - error during ',a,' call, Task = ',    &
     &          i3.3, ' Error = ',i3,/,15x,a)
        exit_flag=2
        RETURN
      END IF
!
!  Unpack gathered data in a continuous memory order and remap every
!  task segment.
!
      nc=0
      DO rank=0,ntasks-1
        ilb=bounds(ng) % Imin(cgrid,ghost,rank)
        iub=bounds(ng) % Imax(cgrid,ghost,rank)
        jlb=bounds(ng) % Jmin(cgrid,ghost,rank)
        jub=bounds(ng) % Jmax(cgrid,ghost,rank)
        DO j=jlb,jub
          jc=(j-joff)*isize
          DO i=ilb,iub
            ij=i+ioff+jc
            nc=nc+1
            awrk(ij)=arecv(nc)
          END DO
        END DO
      END DO
# endif
# ifdef MASKING
!
!  If pocessing only water-points, remove land points and repack.
!
      IF ((myrank.eq.mymaster).and.(gtype.lt.0)) THEN
        nc=0
        DO i=1,ijsize
          IF (awrk(i).lt.spval) THEN
            nc=nc+1
            awrk(nc)=awrk(i)
          END IF
        END DO
        npts=nc
      END IF
# endif
!
!  Deallocate local arrays.
!
      deallocate (arecv)
      deallocate (asend)
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 66, __line__, myfile)
# endif
!
      RETURN

References mod_param::bmemmax, mod_param::bounds, mod_scalars::exit_flag, mod_param::iobounds, mod_parallel::mp_float, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_param::p2dvar, mod_param::p3dvar, mod_param::r2dvar, mod_param::r3dvar, mod_scalars::spval, mod_iounits::stdout, mod_param::tilesize, mod_param::u2dvar, mod_param::u3dvar, mod_param::v2dvar, mod_param::v3dvar, wclock_off(), and wclock_on().

Referenced by nf_fwrite2d_mod::nf_fwrite2d::nf90_fwrite2d(), nf_fwrite3d_mod::nf_fwrite3d::nf90_fwrite3d(), nf_fwrite4d_mod::nf_fwrite4d::nf90_fwrite4d(), pack_field_mod::pack_field2d(), and wpoints_tile().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_gather3d()

subroutine distribute_mod::mp_gather3d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	lbi,
		integer, intent(in)	ubi,
		integer, intent(in)	lbj,
		integer, intent(in)	ubj,
		integer, intent(in)	lbk,
		integer, intent(in)	ubk,
		integer, intent(in)	tindex,
		integer, intent(in)	gtype,
		real(dp), intent(in)	ascl,
		real(r8), dimension(lbi:ubi,lbj:ubj), intent(in)	amask,
		real(r8), dimension(lbi:ubi,lbj:ubj,lbk:ubk), intent(in)	a,
		integer, intent(out)	npts,
		real(r8), dimension(:), intent(out)	awrk,
		logical, intent(in), optional	setfillval )

Definition at line 4725 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects a 3D tiled, floating-point array from each    !
!  spawned node and stores it into one dimensional global array. It    !
!  is used to collect and  pack output data.                           !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     LBi        I-dimension Lower bound.                              !
!     UBi        I-dimension Upper bound.                              !
!     LBj        J-dimension Lower bound.                              !
!     UBj        J-dimension Upper bound.                              !
!     LBk        K-dimension Lower bound.                              !
!     UBk        K-dimension Upper bound.                              !
!     tindex     Time record index to process.                         !
!     gtype      C-grid type. If negative and Land-Sea is available,   !
!                  only water-points processed.                        !
!     Ascl       Factor to scale field before writing.                 !
!     Amask      Land/Sea mask, if any.                                !
!     A          3D tiled, floating-point array to process.            !
!     SetFillVal Logical switch to set fill value in land areas        !
!                  (optional).                                         !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Npts       Number of points processed in Awrk.                   !
!     Awrk       Collected data from each node packed into 1D array    !
!                  in column-major order. That is, in the same way     !
!                  that Fortran multi-dimensional arrays are stored    !
!                  in memory.                                          !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      logical, intent(in), optional :: SetFillVal
!
      integer, intent(in) :: ng, model, tindex, gtype
      integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
      integer, intent(out) :: Npts
!
      real(dp), intent(in) :: Ascl
 
# ifdef MASKING
      real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
# endif
      real(r8), intent(in)  :: A(LBi:UBi,LBj:UBj,LBk:UBk)
      real(r8), intent(out) :: Awrk(:)
!
!  Local variable declarations.
!
# ifdef MASKING
      logical :: LandFill
!
# endif
      integer :: Cgrid, ghost, rank
      integer :: Io, Ie, Jo, Je, Ioff, Joff, Koff
      integer :: Imin, Imax, Jmin, Jmax
      integer :: iLB, iUB, jLB, jUB
      integer :: Asize, Isize, Jsize, Ksize, IJsize
      integer :: Lstr, MyError, MyType, Serror, Srequest
      integer :: i, ic, ijk, j, jc, k, kc, nc
!
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: counts, displs
# ifdef GATHER_SENDRECV
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: MySize
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
 
      integer, dimension(MPI_STATUS_SIZE) :: Rstatus
      integer, dimension(MPI_STATUS_SIZE) :: Sstatus
!
      real(r8), allocatable :: Arecv(:,:)
# else
      real(r8), allocatable :: Arecv(:)
# endif
      real(r8), allocatable :: Asend(:)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_gather3d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 66, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Set horizontal starting and ending indices for parallel domain
!  partitions in the XI- and ETA-directions.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real(2*SIZE(awrk)*kind(a),r8))
!
!  Set full grid first and last point according to staggered C-grid
!  classification. Notice that the offsets are for the private array
!  counter.
!
      mytype=abs(gtype)
 
      SELECT CASE (mytype)
        CASE (p2dvar, p3dvar)
          io=iobounds(ng) % ILB_psi
          ie=iobounds(ng) % IUB_psi
          jo=iobounds(ng) % JLB_psi
          je=iobounds(ng) % JUB_psi
          ioff=0
          joff=1
        CASE (r2dvar, r3dvar)
          io=iobounds(ng) % ILB_rho
          ie=iobounds(ng) % IUB_rho
          jo=iobounds(ng) % JLB_rho
          je=iobounds(ng) % JUB_rho
          ioff=1
          joff=0
        CASE (u2dvar, u3dvar)
          io=iobounds(ng) % ILB_u
          ie=iobounds(ng) % IUB_u
          jo=iobounds(ng) % JLB_u
          je=iobounds(ng) % JUB_u
          ioff=0
          joff=0
        CASE (v2dvar, v3dvar)
          io=iobounds(ng) % ILB_v
          ie=iobounds(ng) % IUB_v
          jo=iobounds(ng) % JLB_v
          je=iobounds(ng) % JUB_v
          ioff=1
          joff=1
        CASE DEFAULT                              ! RHO-points
          io=iobounds(ng) % ILB_rho
          ie=iobounds(ng) % IUB_rho
          jo=iobounds(ng) % JLB_rho
          je=iobounds(ng) % JUB_rho
          ioff=1
          joff=0
      END SELECT
!
      IF (lbk.eq.0) THEN
        koff=0
      ELSE
        koff=1
      END IF
!
      isize=ie-io+1
      jsize=je-jo+1
      ksize=ubk-lbk+1
      ijsize=isize*jsize
      npts=ijsize*ksize
!
!  Set "GATHERV" counts and displacement vectors. Use non-overlapping
!  (ghost=0) ranges according to tile rank.
!
      ghost=0
!
      SELECT CASE (mytype)
        CASE (p2dvar, p3dvar)
          cgrid=1
        CASE (r2dvar, r3dvar)
          cgrid=2
        CASE (u2dvar, u3dvar)
          cgrid=3
        CASE (v2dvar, v3dvar)
          cgrid=4
        CASE DEFAULT                              ! RHO-points
          cgrid=2
      END SELECT
!
      ntasks=ntilei(ng)*ntilej(ng)
      nc=0
      DO rank=0,ntasks-1
        ilb=bounds(ng) % Imin(cgrid,ghost,rank)
        iub=bounds(ng) % Imax(cgrid,ghost,rank)
        jlb=bounds(ng) % Jmin(cgrid,ghost,rank)
        jub=bounds(ng) % Jmax(cgrid,ghost,rank)
# ifdef GATHER_SENDRECV
        mysize(rank)=(iub-ilb+1)*(jub-jlb+1)*(ubk-lbk+1)
# endif
        displs(rank)=nc
        DO k=lbk,ubk
          DO j=jlb,jub
            DO i=ilb,iub
              nc=nc+1
            END DO
          END DO
        END DO
        counts(rank)=nc-displs(rank)
      END DO
!
!-----------------------------------------------------------------------
!  Pack and scale input tiled data.
!-----------------------------------------------------------------------
!
      imin=bounds(ng) % Imin(cgrid,ghost,myrank)
      imax=bounds(ng) % Imax(cgrid,ghost,myrank)
      jmin=bounds(ng) % Jmin(cgrid,ghost,myrank)
      jmax=bounds(ng) % Jmax(cgrid,ghost,myrank)
!
      asize=(imax-imin+1)*(jmax-jmin+1)*(ubk-lbk+1)
      allocate ( asend(asize) )
      asend=0.0_r8
!
      nc=0
      DO k=lbk,ubk
        DO j=jmin,jmax
          DO i=imin,imax
            nc=nc+1
            asend(nc)=a(i,j,k)*ascl
          END DO
        END DO
      END DO
 
# ifdef MASKING
!
!  If overwriting Land/Sea mask or processing water-points only, flag
!  land-points with special value.
!
      IF (PRESENT(setfillval)) THEN
        landfill=setfillval
      ELSE
        landfill=tindex.gt.0
      END IF
      IF (gtype.lt.0) THEN
        nc=0
        DO k=lbk,ubk
          DO j=jmin,jmax
            DO i=imin,imax
              nc=nc+1
              IF (amask(i,j).eq.0.0_r8) THEN
                asend(nc)=spval
              END IF
            END DO
          END DO
        END DO
      ELSE IF (landfill) THEN
        nc=0
        DO k=lbk,ubk
          DO j=jmin,jmax
            DO i=imin,imax
              nc=nc+1
              IF (amask(i,j).eq.0.0_r8) THEN
                asend(nc)=spval
              END IF
            END DO
          END DO
        END DO
      END IF
# endif
!
!-----------------------------------------------------------------------
!  Gather requested global data from tiled arrays.
!-----------------------------------------------------------------------
 
# ifdef GATHER_SENDRECV
!
      allocate ( arecv(ijsize*ksize, ntasks-1) )
      arecv=0.0_r8      
!
!  If master processor, unpack the send buffer since there is not
!  need to distribute.
!
      IF (myrank.eq.mymaster) THEN
        nc=0
        DO k=lbk,ubk
          kc=(k-koff)*ijsize
          DO j=jmin,jmax
            jc=(j-joff)*isize
            DO i=imin,imax
              nc=nc+1
              ic=i+ioff+jc+kc
              awrk(ic)=asend(nc)
            END DO
          END DO
        END DO
      END IF
!
!  Send, receive, and unpack data.
!
      IF (myrank.eq.mymaster) THEN
        DO rank=1,ntasks-1
          CALL mpi_irecv (arecv(1,rank), mysize(rank), mp_float, rank,  &
     &                    rank+5, ocn_comm_world, rrequest(rank),       &
     &                    myerror)
        END DO
        DO rank=1,ntasks-1
          CALL mpi_wait (rrequest(rank), rstatus, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,10) 'MPI_IRECV', rank, myerror, string(1:lstr)
 10         FORMAT (/,' MP_GATHER3D - error during ',a,' call, Task = ',&
     &              i3.3,' Error = ',i3,/,13x,a)
            exit_flag=2
            RETURN
          END IF
!
          imin=bounds(ng) % Imin(cgrid,ghost,rank)
          imax=bounds(ng) % Imax(cgrid,ghost,rank)
          jmin=bounds(ng) % Jmin(cgrid,ghost,rank)
          jmax=bounds(ng) % Jmax(cgrid,ghost,rank)
!
          nc=0
          DO k=lbk,ubk
            kc=(k-koff)*ijsize
            DO j=jmin,jmax
              jc=(j-joff)*isize
              DO i=imin,imax
                nc=nc+1
                ic=i+ioff+jc+kc
                awrk(ic)=arecv(nc,rank)
              END DO
            END DO
          END DO
        END DO
      ELSE
        CALL mpi_isend (asend, mysize(myrank), mp_float, mymaster,      &
     &                  myrank+5, ocn_comm_world, srequest, myerror)
        CALL mpi_wait (srequest, sstatus, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ISEND', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
 
# else
!
!  Gather local tiled data into a global array.
!
      allocate ( arecv(ijsize*ksize) )
      arecv=0.0_r8
!
      CALL mpi_gatherv (asend, asize, mp_float,                         &
     &                  arecv, counts, displs, mp_float,                &
     &                  mymaster, ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        WRITE (stdout,10) 'MPI_GATHERV', myrank, myerror, trim(string)
 10     FORMAT (/,' MP_GATHER3D - error during ',a,' call, Task = ',    &
     &          i3.3, ' Error = ',i3,/,15x,a)
        exit_flag=2
        RETURN
      END IF
!
!  Unpack gathered data in a continuous memory order and remap every
!  task segment.
!
      nc=0
      DO rank=0,ntasks-1
        ilb=bounds(ng) % Imin(cgrid,ghost,rank)
        iub=bounds(ng) % Imax(cgrid,ghost,rank)
        jlb=bounds(ng) % Jmin(cgrid,ghost,rank)
        jub=bounds(ng) % Jmax(cgrid,ghost,rank)
        DO k=lbk,ubk
          kc=(k-koff)*ijsize
          DO j=jlb,jub
            jc=(j-joff)*isize
            DO i=ilb,iub
              ijk=i+ioff+jc+kc
              nc=nc+1
              awrk(ijk)=arecv(nc)
            END DO
          END DO
        END DO
      END DO
# endif
# ifdef MASKING
!
!  If pocessing only water-points, remove land points and repack.
!
      IF ((myrank.eq.mymaster).and.(gtype.lt.0)) THEN
        nc=0
        DO i=1,ijsize*ksize
          IF (awrk(i).lt.spval) THEN
            nc=nc+1
            awrk(nc)=awrk(i)
          END IF
        END DO
        npts=nc
      END IF
# endif
!
!  Deallocate local arrays.
!
      deallocate (arecv)
      deallocate (asend)
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 66, __line__, myfile)
# endif
!
      RETURN

References mod_param::bmemmax, mod_param::bounds, mod_scalars::exit_flag, mod_param::iobounds, mod_parallel::mp_float, mod_parallel::mymaster, mod_parallel::myrank, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_param::p2dvar, mod_param::p3dvar, mod_param::r2dvar, mod_param::r3dvar, mod_scalars::spval, mod_iounits::stdout, mod_param::u2dvar, mod_param::u3dvar, mod_param::v2dvar, mod_param::v3dvar, wclock_off(), and wclock_on().

Referenced by nf_fwrite3d_mod::nf_fwrite3d::nf90_fwrite3d(), nf_fwrite4d_mod::nf_fwrite4d::nf90_fwrite4d(), pack_field_mod::pack_field3d(), and pack_field_mod::pack_field4d().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_gather_state()

subroutine distribute_mod::mp_gather_state	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	mstr,
		integer, intent(in)	mend,
		integer, intent(in)	asize,
		real(r8), dimension(mstr:mend), intent(in)	a,
		real(r8), dimension(asize), intent(out)	awrk )

Definition at line 5141 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine gathers (threaded to global) state data to all nodes   !
!  in the group. This  routine  is used to unpack the state data for   !
!  the GST analysis propagators.                                       !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Mstr       Threaded array lower bound.                           !
!     Mend       Threaded array upper bound.                           !
!     Asize      Size of the full state.                               !
!     A          Threaded 1D array process.                            !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Awrk       Collected data from each node packed into 1D full     !
!                  state array.                                        !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
      integer, intent(in) :: Mstr, Mend, Asize
!
      real(r8), intent(in)  :: A(Mstr:Mend)
      real(r8), intent(out) :: Awrk(Asize)
!
!  Local variable declarations.
!
      integer :: LB, Lstr, MyError, Serror
      integer :: i, np, rank, request
 
      integer :: my_bounds(2)
      integer, dimension(MPI_STATUS_SIZE) :: status
      integer, dimension(2,0:NtileI(ng)*NtileJ(ng)-1) :: Abounds
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_gather_state"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 66, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Collect data from all nodes.
!-----------------------------------------------------------------------
!
!  Collect data lower and upper bound dimensions.
!
      np=2
      my_bounds(1)=mstr
      my_bounds(2)=mend
      CALL mpi_allgather (my_bounds, np, mpi_integer, abounds, np,      &
     &                    mpi_integer, ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
 10     FORMAT (/,' MP_GATHER_STATE - error during ',a,                 &
     &          ' call, Task = ',i3.3,' Error = ',i3,/,13x,a)
        exit_flag=2
        RETURN
      END IF
!
!  If master node, loop over other nodes and receive the data.
!
      IF (myrank.eq.mymaster) THEN
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          np=abounds(2,rank)-abounds(1,rank)+1
          lb=abounds(1,rank)
          CALL mpi_irecv (awrk(lb:), np, mp_float, rank, rank+5,        &
     &                    ocn_comm_world, 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,10) 'MPI_IRECV', rank, myerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
        END DO
!
!  Load master node contribution.
!
        DO i=mstr,mend
          awrk(i)=a(i)
        END DO
!
!  Otherwise, send data to master node.
!
      ELSE
        np=mend-mstr+1
        CALL mpi_isend (a(mstr:), np, mp_float, mymaster, myrank+5,     &
     &                  ocn_comm_world, 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,10) 'MPI_ISEND', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast collected data to all nodes.
!
      CALL mpi_bcast (awrk, asize, mp_float, mymaster, ocn_comm_world,  &
     &                myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 66, __line__, myfile)
# endif
!
      RETURN

References mod_scalars::exit_flag, 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().

Referenced by ad_unpack(), ad_unpack_tile(), tl_unpack(), and tl_unpack_tile().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_ncread1d()

integer function distribute_mod::mp_ncread1d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	ncid,
		character (len=*), intent(in)	ncvname,
		character (len=*), intent(in)	ncname,
		integer, intent(in)	ncrec,
		integer, intent(in)	lb1,
		integer, intent(in)	ub1,
		real(r8), intent(in)	ascale,
		real(r8), dimension(lb1:ub1), intent(out)	a )

Definition at line 5283 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This function reads floating point 1D state array from specified    !
!  NetCDF file and scatters it to the other nodes.                     !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng           Nested grid number.                                 !
!     model        Calling model identifier.                           !
!     ncid         NetCDF file ID.                                     !
!     ncvname      NetCDF variable name.                               !
!     ncname       NetCDF file name.                                   !
!     ncrec        NetCDF record index to write. If negative, it       !
!                    assumes that the variable is recordless.          !
!     LB1          First-dimension Lower bound.                        !
!     UB1          First-dimension Upper bound.                        !
!     Ascale       Factor to scale field after reading (real).         !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A            Field to read in (real).                            !
!     io_error     Error flag (integer).                               !
!                                                                      !
!  Note: We cannot include "USE mod_netcdf" here because of cyclic     !
!        dependency. Instead we need original NetCDF library module    !
!        "USE netcdf".                                                 !
!                                                                      !
!***********************************************************************
!
      USE netcdf
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, ncid, ncrec
      integer, intent(in) :: LB1, UB1
!
      real(r8), intent(in) :: Ascale
 
      real(r8), intent(out) :: A(LB1:UB1)
!
      character (len=*), intent(in) :: ncvname
      character (len=*), intent(in) :: ncname
!
!  Local variable declarations.
!
      integer :: Lstr, MyError, Npts, Serror
      integer :: i, j, np, rank, request, varid
      integer :: io_error
      integer :: ibuffer(2), my_bounds(2), start(1), total(1)
 
      integer, dimension(MPI_STATUS_SIZE) :: status
      integer, dimension(4,0:NtileI(ng)*NtileJ(ng)-1) :: Asize
!
      real(r8), allocatable :: Asend(:)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_ncread1d_nf90"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 67, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Read requested NetCDF file and scatter it to all nodes.
!-----------------------------------------------------------------------
!
      io_error=nf90_noerr
!
!  Collect data lower and upper bounds dimensions.
!
      np=2
      my_bounds(1)=lb1
      my_bounds(2)=ub1
      CALL mpi_allgather (my_bounds, np, mpi_integer,                   &
     &                    asize, np, mpi_integer,                        &
     &                    ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  If not master node, receive data from master node.
!
      IF (myrank.ne.mymaster) THEN
        np=ub1-lb1+1
        CALL mpi_irecv (a(lb1:), np, mp_float, mymaster, myrank+5,      &
     &                  ocn_comm_world, 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,10) 'MPI_IRECV', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
!
!  Scale recieved (read) data.
!
        DO i=lb1,ub1
          a(i)=a(i)*ascale
        END DO
!
!  Otherwise, if master node allocate the send buffer.
!
      ELSE
        npts=0
        DO rank=0,ntilei(ng)*ntilej(ng)-1
          np=asize(2,rank)-asize(1,rank)+1
          npts=max(npts, np)
        END DO
        IF (.not.allocated(asend)) THEN
          allocate (asend(npts))
        END IF
!
!  If master node, loop over all nodes and read buffers to send.
!
        io_error=nf90_inq_varid(ncid, trim(ncvname), varid)
        IF (io_error.ne.nf90_noerr) THEN
          WRITE (stdout,20) trim(ncvname), trim(ncname)
          exit_flag=2
          ioerror=io_error
        END IF
        IF (exit_flag.eq.noerror) THEN
          DO rank=0,ntilei(ng)*ntilej(ng)-1
            start(1)=asize(1,rank)
            total(1)=asize(2,rank)-asize(1,rank)+1
            io_error=nf90_get_var(ncid, varid,  asend, start, total)
            IF (io_error.ne.nf90_noerr) THEN
              WRITE (stdout,30) trim(ncvname), trim(ncname)
              exit_flag=2
              ioerror=io_error
              EXIT
            END IF
!
!  Send buffer to all nodes, except itself.
!
            IF (rank.eq.mymaster) THEN
              np=0
              DO i=lb1,ub1
                np=np+1
                a(i)=asend(np)*ascale
              END DO
            ELSE
              np=asize(2,rank)-asize(1,rank)+1
              CALL mpi_isend (asend, np, mp_float, rank, rank+5,        &
     &                        ocn_comm_world, 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,10) 'MPI_ISEND', rank, myerror,           &
     &                            string(1:lstr)
                exit_flag=2
                RETURN
              END IF
            END IF
          END DO
        END IF
      END IF
!
!  Broadcast error flags to all nodes.
!
      ibuffer(1)=exit_flag
      ibuffer(2)=ioerror
      CALL mp_bcasti (ng, model, ibuffer)
      exit_flag=ibuffer(1)
      ioerror=ibuffer(2)
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real(SIZE(asend)*kind(a),r8))
!
!  Deallocate send buffer.
!
      IF (allocated(asend).and.(myrank.eq.mymaster)) THEN
        deallocate (asend)
      END IF
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 67, __line__, myfile)
# endif
!
 10   FORMAT (/,' MP_NCREAD1D - error during ',a,' call, Task = ',i0,   &
     &        ' Error = ',i0,/,15x,a)
 20   FORMAT (/,' MP_NCREAD1D - error while inquiring ID for',          &
     &        ' variable: ',a,/,15x,'in file: ',a)
 30   FORMAT (/,' MP_NCREAD1D - error while reading variable: ',a,      &
     &        /,15x,'in file: ',a)
!
      RETURN

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

Referenced by get_gst_mod::get_gst_nf90().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_ncread2d()

integer function distribute_mod::mp_ncread2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	ncid,
		character (len=*), intent(in)	ncvname,
		character (len=*), intent(in)	ncname,
		integer, intent(in)	ncrec,
		integer, intent(in)	lb1,
		integer, intent(in)	ub1,
		integer, intent(in)	lb2,
		integer, intent(in)	ub2,
		real(r8), intent(in)	ascale,
		real(r8), dimension(lb1:ub1,lb2:ub2), intent(out)	a )

Definition at line 5495 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This function reads floating point 2D state array from specified    !
!  NetCDF file and scatters it to the other nodes.                     !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng           Nested grid number.                                 !
!     model        Calling model identifier.                           !
!     ncid         NetCDF file ID.                                     !
!     ncvname      NetCDF variable name.                               !
!     ncname       NetCDF file name.                                   !
!     ncrec        NetCDF record index to write. If negative, it       !
!                    assumes that the variable is recordless.          !
!     LB1          First-dimension Lower bound.                        !
!     UB1          First-dimension Upper bound.                        !
!     LB2          Second-dimension Lower bound.                       !
!     UB2          Second-dimension Upper bound.                       !
!     Ascale       Factor to scale field after reading (real).         !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A            Field to read in (real).                            !
!     io_error     Error flag (integer).                               !
!                                                                      !
!  Note: We cannot include "USE mod_netcdf" here because of cyclic     !
!        dependency. Instead we need original NetCDF library module    !
!        "USE netcdf".                                                 !
!                                                                      !
!***********************************************************************
!
      USE netcdf
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, ncid, ncrec
      integer, intent(in) :: LB1, UB1, LB2, UB2
!
      real(r8), intent(in) :: Ascale
 
      real(r8), intent(out) :: A(LB1:UB1,LB2:UB2)
!
      character (len=*), intent(in) :: ncvname
      character (len=*), intent(in) :: ncname
!
!  Local variable declarations.
!
      integer :: Lstr, MyError, Npts, Serror
      integer :: i, j, np, rank, request, varid
      integer :: io_error
      integer :: ibuffer(2), my_bounds(4), start(2), total(2)
 
      integer, dimension(MPI_STATUS_SIZE) :: status
      integer, dimension(4,0:NtileI(ng)*NtileJ(ng)-1) :: Asize
!
      real(r8), allocatable :: Asend(:)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_ncread2d_nf90"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 67, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Read requested NetCDF file and scatter it to all nodes.
!-----------------------------------------------------------------------
!
      io_error=nf90_noerr
!
!  Collect data lower and upper bounds dimensions.
!
      np=4
      my_bounds(1)=lb1
      my_bounds(2)=ub1
      my_bounds(3)=lb2
      my_bounds(4)=ub2
      CALL mpi_allgather (my_bounds, np, mpi_integer,                   &
     &                    asize, np, mpi_integer,                       &
     &                    ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  If not master node, receive data from master node.
!
      IF (myrank.ne.mymaster) THEN
        np=(ub1-lb1+1)*(ub2-lb2+1)
        CALL mpi_irecv (a(lb1,lb2), np, mp_float, mymaster, myrank+5,   &
     &                  ocn_comm_world, 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,10) 'MPI_IRECV', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
!
!  Scale recieved (read) data.
!
        DO j=lb2,ub2
          DO i=lb1,ub1
            a(i,j)=a(i,j)*ascale
          END DO
        END DO
!
!  Otherwise, if master node allocate the send buffer.
!
      ELSE
        npts=0
        DO rank=0,ntilei(ng)*ntilej(ng)-1
          np=(asize(2,rank)-asize(1,rank)+1)*                           &
     &       (asize(4,rank)-asize(3,rank)+1)
          npts=max(npts, np)
        END DO
        IF (.not.allocated(asend)) THEN
          allocate (asend(npts))
        END IF
!
!  If master node, loop over all nodes and read buffers to send.
!
        io_error=nf90_inq_varid(ncid, trim(ncvname), varid)
        IF (io_error.ne.nf90_noerr) THEN
          WRITE (stdout,20) trim(ncvname), trim(ncname)
          exit_flag=2
          ioerror=io_error
        END IF
        IF (exit_flag.eq.noerror) THEN
          DO rank=0,ntilei(ng)*ntilej(ng)-1
            start(1)=asize(1,rank)
            total(1)=asize(2,rank)-asize(1,rank)+1
            start(2)=asize(3,rank)
            total(2)=asize(4,rank)-asize(3,rank)+1
            io_error=nf90_get_var(ncid, varid,  asend, start, total)
            IF (io_error.ne.nf90_noerr) THEN
              WRITE (stdout,30) trim(ncvname), trim(ncname)
              exit_flag=2
              ioerror=io_error
              EXIT
            END IF
!
!  Send buffer to all nodes, except itself.
!
            IF (rank.eq.mymaster) THEN
              np=0
              DO j=lb2,ub2
                DO i=lb1,ub1
                  np=np+1
                  a(i,j)=asend(np)*ascale
                END DO
              END DO
            ELSE
              np=(asize(2,rank)-asize(1,rank)+1)*                       &
     &           (asize(4,rank)-asize(3,rank)+1)
              CALL mpi_isend (asend, np, mp_float, rank, rank+5,        &
     &                        ocn_comm_world, 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,10) 'MPI_ISEND', rank, myerror,           &
     &                            string(1:lstr)
                exit_flag=2
                RETURN
              END IF
            END IF
          END DO
        END IF
      END IF
!
!  Broadcast error flags to all nodes.
!
      ibuffer(1)=exit_flag
      ibuffer(2)=ioerror
      CALL mp_bcasti (ng, model, ibuffer)
      exit_flag=ibuffer(1)
      ioerror=ibuffer(2)
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real(SIZE(asend)*kind(a),r8))
!
!  Deallocate send buffer.
!
      IF (allocated(asend).and.(myrank.eq.mymaster)) THEN
        deallocate (asend)
      END IF
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 67, __line__, myfile)
# endif
!
 10   FORMAT (/,' MP_NCREAD2D - error during ',a,' call, Task = ',i0,   &
     &        ' Error = ',i0,/,15x,a)
 20   FORMAT (/,' MP_NCREAD2D - error while inquiring ID for',          &
     &        ' variable: ',a,/,15x,'in file: ',a)
 30   FORMAT (/,' MP_NCREAD2D - error while reading variable: ',a,      &
     &        /,15x,'in file: ',a)
!
      RETURN

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

Referenced by get_gst_mod::get_gst_nf90().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_ncwrite1d()

integer function distribute_mod::mp_ncwrite1d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	ncid,
		character (len=*), intent(in)	ncvname,
		character (len=*), intent(in)	ncname,
		integer, intent(in)	ncrec,
		integer, intent(in)	lb1,
		integer, intent(in)	ub1,
		real(r8), intent(in)	ascale,
		real(r8), dimension(lb1:ub1), intent(in)	a )

Definition at line 5719 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This function collects floating point 1D state array data from the  !
!  other nodes and writes it into specified NetCDF file.               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng            Nested grid number.                                !
!     model         Calling model identifier.                          !
!     ncid          NetCDF file ID.                                    !
!     ncvname       NetCDF variable name.                              !
!     ncname        NetCDF file name.                                  !
!     ncrec         NetCDF record index to write. If negative, it      !
!                     assumes that the variable is recordless.         !
!     LB1           First-dimension Lower bound.                       !
!     UB1           First-dimension Upper bound.                       !
!     Ascale        Factor to scale field before writing (real).       !
!     A             Field to write out (real).                         !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     io_error      Error flag (integer).                              !
!                                                                      !
!  Note: We cannot include "USE mod_netcdf" here because of cyclic     !
!        dependency. Instead we need original NetCDF library module    !
!        "USE netcdf".                                                 !
!                                                                      !
!***********************************************************************
!
      USE netcdf
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, ncid, ncrec
      integer, intent(in) :: LB1, UB1
!
      real(r8), intent(in) :: Ascale
 
      real(r8), intent(in) :: A(LB1:UB1)
 
      character (len=*), intent(in) :: ncvname
      character (len=*), intent(in) :: ncname
!
!  Local variable declarations.
!
      integer :: Lstr, MyError, Npts, Serror
      integer :: i, j, np, rank, request, varid
      integer :: io_error
      integer :: ibuffer(2), my_bounds(2), start(1), total(1)
 
      integer, dimension(MPI_STATUS_SIZE) :: status
      integer, dimension(2,0:NtileI(ng)*NtileJ(ng)-1) :: Asize
!
      real(r8), allocatable :: Arecv(:)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_ncwrite1d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 66, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Collect and write data into requested NetCDF file.
!-----------------------------------------------------------------------
!
      io_error=nf90_noerr
!
!  Collect data lower and upper bounds dimensions.
!
      np=2
      my_bounds(1)=lb1
      my_bounds(2)=ub1
      CALL mpi_allgather (my_bounds, np, mpi_integer,                   &
     &                    asize, np, mpi_integer,                       &
     &                    ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  If master node, allocate the receive buffer.
!
      IF (myrank.eq.mymaster) THEN
        npts=0
        DO rank=0,ntilei(ng)*ntilej(ng)-1
          np=(asize(2,rank)-asize(1,rank)+1)
          npts=max(npts, np)
        END DO
        IF (.not.allocated(arecv)) THEN
          allocate (arecv(npts))
        END IF
!
!  Write out master node contribution.
!
        start(1)=lb1
        total(1)=ub1-lb1+1
        np=0
        DO i=lb1,ub1
          np=np+1
          arecv(np)=a(i)
        END DO
        io_error=nf90_inq_varid(ncid, trim(ncvname), varid)
        IF (io_error.eq.nf90_noerr) THEN
          io_error=nf90_put_var(ncid, varid, arecv, start, total)
          IF (io_error.ne.nf90_noerr) THEN
            WRITE (stdout,20) trim(ncvname), trim(ncname)
            exit_flag=3
            ioerror=io_error
          END IF
        ELSE
          WRITE (stdout,30) trim(ncvname), trim(ncname)
          exit_flag=3
          ioerror=io_error
        END IF
!
!  If master node, loop over other nodes and receive the data.
!
        IF (exit_flag.eq.noerror) THEN
          DO rank=1,ntilei(ng)*ntilej(ng)-1
            np=asize(2,rank)-asize(1,rank)+1
            CALL mpi_irecv (arecv, np, mp_float, rank, rank+5,          &
     &                      ocn_comm_world, 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,10) 'MPI_IRECV', rank, myerror,             &
     &                          string(1:lstr)
              exit_flag=3
              RETURN
            END IF
!
!  Write out data into NetCDF file.
!
            start(1)=asize(1,rank)
            total(1)=asize(2,rank)-asize(1,rank)+1
            DO i=1,np
              arecv(i)=arecv(i)*ascale
            END DO
            io_error=nf90_put_var(ncid, varid, arecv, start, total)
            IF (io_error.ne.nf90_noerr) THEN
              WRITE (stdout,20) trim(ncvname), trim(ncname)
              exit_flag=3
              ioerror=io_error
              EXIT
            END IF
          END DO
        END IF
!
!  Otherwise, send data to master node.
!
      ELSE
        np=ub1-lb1+1
        CALL mpi_isend (a(lb1:), np, mp_float, mymaster, myrank+5,      &
     &                  ocn_comm_world, 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,10) 'MPI_ISEND', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast error flags to all nodes.
!
      ibuffer(1)=exit_flag
      ibuffer(2)=ioerror
      CALL mp_bcasti (ng, model, ibuffer)
      exit_flag=ibuffer(1)
      ioerror=ibuffer(2)
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real(SIZE(arecv)*kind(a),r8))
!
!  Deallocate receive buffer.
!
      IF (allocated(arecv).and.(myrank.eq.mymaster)) THEN
        deallocate (arecv)
      END IF
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 66, __line__, myfile)
# endif
!
 10   FORMAT (/,' MP_NCWRITE1D - error during ',a,' call, Task = ',i0,  &
     &        ' Error = ',i0,/,21x,a)
 20   FORMAT (/,' MP_NCWRITE1D - error while writing variable: ',a,     &
     &        /,16x,'in file: ',a)
 30   FORMAT (/,' MP_NCWRITE1D - error while inquiring ID for',         &
     &        ' variable: ',a,/,16x,'in file: ',a)
!
      RETURN

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

Referenced by wrt_gst_mod::wrt_gst_nf90().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_ncwrite2d()

integer function distribute_mod::mp_ncwrite2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	ncid,
		character (len=*), intent(in)	ncvname,
		character (len=*), intent(in)	ncname,
		integer, intent(in)	ncrec,
		integer, intent(in)	lb1,
		integer, intent(in)	ub1,
		integer, intent(in)	lb2,
		integer, intent(in)	ub2,
		real(r8), intent(in)	ascale,
		real(r8), dimension(lb1:ub1,lb2:ub2), intent(in)	a )

Definition at line 5937 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This function collects floating point 2D state array data from the  !
!  other nodes and writes it into specified NetCDF file.               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng            Nested grid number.                                !
!     model         Calling model identifier.                          !
!     ncid          NetCDF file ID.                                    !
!     ncvname       NetCDF variable name.                              !
!     ncname        NetCDF file name.                                  !
!     ncrec         NetCDF record index to write. If negative, it      !
!                     assumes that the variable is recordless.         !
!     LB1           First-dimension Lower bound.                       !
!     UB1           First-dimension Upper bound.                       !
!     LB2           Second-dimension Lower bound.                      !
!     UB2           Second-dimension Upper bound.                      !
!     Ascale        Factor to scale field before writing (real).       !
!     A             Field to write out (real).                         !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     io_error      Error flag (integer).                              !
!                                                                      !
!  Note: We cannot include "USE mod_netcdf" here because of cyclic     !
!        dependency. Instead we need original NetCDF library module    !
!        "USE netcdf".                                                 !
!                                                                      !
!***********************************************************************
!
      USE netcdf
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, ncid, ncrec
      integer, intent(in) :: LB1, UB1, LB2, UB2
!
      real(r8), intent(in) :: Ascale
 
      real(r8), intent(in) :: A(LB1:UB1,LB2:UB2)
!
      character (len=*), intent(in) :: ncvname
      character (len=*), intent(in) :: ncname
!
!  Local variable declarations.
!
      integer :: Lstr, MyError, Npts, Serror
      integer :: i, j, np, rank, request, varid
      integer :: io_error
      integer :: ibuffer(2), my_bounds(4), start(2), total(2)
 
      integer, dimension(MPI_STATUS_SIZE) :: status
      integer, dimension(4,0:NtileI(ng)*NtileJ(ng)-1) :: Asize
!
      real(r8), allocatable :: Arecv(:)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_ncwrite2d_nf90"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 66, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Collect and write data into requested NetCDF file.
!-----------------------------------------------------------------------
!
      io_error=nf90_noerr
!
!  Collect data lower and upper bounds dimensions.
!
      np=4
      my_bounds(1)=lb1
      my_bounds(2)=ub1
      my_bounds(3)=lb2
      my_bounds(4)=ub2
      CALL mpi_allgather (my_bounds, np, mpi_integer,                   &
     &                    asize, np, mpi_integer,                       &
     &                    ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  If master node, allocate the receive buffer.
!
      IF (myrank.eq.mymaster) THEN
        npts=0
        DO rank=0,ntilei(ng)*ntilej(ng)-1
          np=(asize(2,rank)-asize(1,rank)+1)*                           &
     &       (asize(4,rank)-asize(3,rank)+1)
          npts=max(npts, np)
        END DO
        IF (.not.allocated(arecv)) THEN
          allocate (arecv(npts))
        END IF
!
!  Write out master node contribution.
!
        start(1)=lb1
        total(1)=ub1-lb1+1
        start(2)=lb2
        total(2)=ub2-lb2+1
        np=0
        DO j=lb2,ub2
          DO i=lb1,ub1
            np=np+1
            arecv(np)=a(i,j)
          END DO
        END DO
        io_error=nf90_inq_varid(ncid, trim(ncvname), varid)
        IF (io_error.eq.nf90_noerr) THEN
          io_error=nf90_put_var(ncid, varid, arecv, start, total)
          IF (io_error.ne.nf90_noerr) THEN
            WRITE (stdout,20) trim(ncvname), trim(ncname)
            exit_flag=3
            ioerror=io_error
          END IF
        ELSE
          WRITE (stdout,30) trim(ncvname), trim(ncname)
          exit_flag=3
          ioerror=io_error
        END IF
!
!  If master node, loop over other nodes and receive the data.
!
        IF (exit_flag.eq.noerror) THEN
          DO rank=1,ntilei(ng)*ntilej(ng)-1
            np=(asize(2,rank)-asize(1,rank)+1)*                         &
     &         (asize(4,rank)-asize(3,rank)+1)
            CALL mpi_irecv (arecv, np, mp_float, rank, rank+5,          &
     &                      ocn_comm_world, 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,10) 'MPI_IRECV', rank, myerror,             &
     &                          string(1:lstr)
              exit_flag=3
              RETURN
            END IF
!
!  Write out data into NetCDF file.
!
            start(1)=asize(1,rank)
            total(1)=asize(2,rank)-asize(1,rank)+1
            start(2)=asize(3,rank)
            total(2)=asize(4,rank)-asize(3,rank)+1
            DO i=1,np
              arecv(i)=arecv(i)*ascale
            END DO
            io_error=nf90_put_var(ncid, varid, arecv, start, total)
            IF (io_error.ne.nf90_noerr) THEN
              WRITE (stdout,20) trim(ncvname), trim(ncname)
              exit_flag=3
              ioerror=io_error
              EXIT
            END IF
          END DO
        END IF
!
!  Otherwise, send data to master node.
!
      ELSE
        np=(ub1-lb1+1)*(ub2-lb2+1)
        CALL mpi_isend (a(lb1:,lb2:), np, mp_float, mymaster, myrank+5, &
     &                  ocn_comm_world, 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,10) 'MPI_ISEND', myrank, myerror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast error flags to all nodes.
!
      ibuffer(1)=exit_flag
      ibuffer(2)=ioerror
      CALL mp_bcasti (ng, model, ibuffer)
      exit_flag=ibuffer(1)
      ioerror=ibuffer(2)
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real(SIZE(arecv)*kind(a),r8))
!
!  Deallocate receive buffer.
!
      IF (allocated(arecv).and.(myrank.eq.mymaster)) THEN
        deallocate (arecv)
      END IF
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 66, __line__, myfile)
# endif
!
 10   FORMAT (/,' MP_NCWRITE2D - error during ',a,' call, Task = ',i0,  &
     &        ' Error = ',i0,/,21x,a)
 20   FORMAT (/,' MP_NCWRITE2D - error while writing variable: ',a,     &
     &        /,16x,'in file: ',a)
 30   FORMAT (/,' MP_NCWRITE2D - error while inquiring ID for',         &
     &        ' variable: ',a,/,16x,'in file: ',a)
!
      RETURN

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

Referenced by wrt_gst_mod::wrt_gst_nf90().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_reduce2()

subroutine distribute_mod::mp_reduce2	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	isize,
		integer, intent(in)	jsize,
		real(r8), dimension(isize,jsize), intent(inout)	a,
		character (len=*), dimension(jsize), intent(in)	handle_op,
		integer, intent(in), optional	inpcomm )

Definition at line 7191 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine computes the global minimum/maximum and its associated !
!  qualifiers like: location and/or other scalar components.  Then, it !
!  it broadcasts reduced variables to all nodes in the group.          !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Isize      Size of I-dimension: the minimum/maximum to reduce    !
!                  is in location A(1,:) and qualifiers A(2:Isize,:).  !
!     Jsize      Size of J-dimension: number of different sets of      !
!                  minimum and/or maximum to process.                  !
!     A          Matrix of variables and qualifiers to reduce.         !
!     handle_op  Reduction operation handle (string) of size Jsize.    !
!                  The following  reduction operations are supported:  !
!                  'MINLOC', 'MAXLOC'                                  !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Matrix of reduced variables and qualifiers.           !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Isize, Jsize
 
      integer, intent(in), optional :: InpComm
!
      character (len=*), intent(in) :: handle_op(Jsize)
!
      real(r8), intent(inout) :: A(Isize,Jsize)
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, Serror
      integer :: handle, i, j
!
      real(r8), dimension(2,Isize) :: Areduce
      real(r8), dimension(2,Isize) :: Asend
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_reduce2"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 65, __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
!
!-----------------------------------------------------------------------
!  Reduce requested variables and qualifiers.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real((SIZE(areduce)+                 &
     &                                   SIZE(asend))*kind(a),r8))
!
!  Pack and reduce.
!
      DO j=1,jsize
        DO i=1,isize
          asend(1,i)=a(1,j)
          asend(2,i)=a(i,j)
        END DO
        IF (handle_op(j)(1:6).eq.'MINLOC') THEN
          handle=mpi_minloc
        ELSE IF (handle_op(j)(1:6).eq.'MAXLOC') THEN
          handle=mpi_maxloc
        END IF
        CALL mpi_allreduce (asend, areduce, isize,                      &
# ifdef DOUBLE_PRECISION
     &                      mpi_2double_precision,                      &
# else
     &                      mpi_2real,                                  &
# endif
     &                      handle, mycomm, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror,           &
     &                      string(1:lstr)
 10       FORMAT (/,' MP_REDUCE2 - error during ',a,' call, Task = ',   &
     &            i3.3,' Error = ',i3,/,16x,a)
          exit_flag=2
          RETURN
        END IF
!
!  Unpack.
!
        a(1,j)=areduce(1,1)
        DO i=2,isize
          a(i,j)=areduce(2,i)
        END DO
      END DO
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 65, __line__, myfile)
# endif
!
      RETURN

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

Referenced by diag_mod::diag_tile().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_reduce_0d()

subroutine distribute_mod::mp_reduce_0d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	asize,
		real(r8), intent(inout)	a,
		character (len=*), intent(in)	handle_op,
		integer, intent(in), optional	inpcomm )

Definition at line 6786 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects and reduces requested variables from all      !
!  nodes in the group.  Then,  it broadcasts reduced variables to      !
!  all nodes in the group.                                             !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Asize      Number of scalar variables to reduce.                 !
!     A          Vector of scalar variables to reduce.                 !
!     handle_op  Reduction operation handle (string).  The following   !
!                  reduction operations are supported:                 !
!                  'MIN', 'MAX', 'SUM'                                 !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Vector of reduced scalar variables.                   !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Asize
 
      integer, intent(in), optional :: InpComm
!
      character (len=*), intent(in) :: handle_op
!
      real(r8), intent(inout) :: A
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
      integer :: handle, i, rank, request
 
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
 
      integer, dimension(MPI_STATUS_SIZE) :: Rstatus
      integer, dimension(MPI_STATUS_SIZE) :: Sstatus
!
      real(r8) :: Areduce
      real(r8) :: Asend
      real(r8), dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_reduce_0d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 65, __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
!
!-----------------------------------------------------------------------
!  Collect and reduce requested scalar variables.
!-----------------------------------------------------------------------
!
!  Pack data to reduce.
!
      asend=a
      npts=1
!
!  Collect and reduce.
!
# if defined REDUCE_ALLREDUCE
      IF (handle_op(1:3).eq.'MIN') THEN
        handle=mpi_min
      ELSE IF (handle_op(1:3).eq.'MAX') THEN
        handle=mpi_max
      ELSE IF (handle_op(1:3).eq.'SUM') THEN
        handle=mpi_sum
      END IF
      CALL mpi_allreduce (asend, areduce, npts, mp_float, handle,       &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# elif defined REDUCE_ALLGATHER
      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,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
      areduce=arecv(0)
      DO rank=1,ntilei(ng)*ntilej(ng)-1
        IF (handle_op(1:3).eq.'MIN') THEN
          areduce=min(areduce,arecv(rank))
        ELSE IF (handle_op(1:3).eq.'MAX') THEN
          areduce=max(areduce,arecv(rank))
        ELSE IF (handle_op(1:3).eq.'SUM') THEN
          areduce=areduce+arecv(rank)
        END IF
      END DO
# elif defined REDUCE_SENDRECV
      IF (myrank.eq.mymaster) THEN
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_irecv (arecv(rank), npts, mp_float, rank,            &
     &                    rank+500, mycomm, rrequest(rank),             &
     &                    myerror)
        END DO
        areduce=asend
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_wait (rrequest(rank), rstatus, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,10) 'MPI_IRECV', rank, rerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
          IF (handle_op(1:3).eq.'MIN') THEN
            areduce=min(areduce,arecv(rank))
          ELSE IF (handle_op(1:3).eq.'MAX') THEN
            areduce=max(areduce,arecv(rank))
          ELSE IF (handle_op(1:3).eq.'SUM') THEN
            areduce=areduce+arecv(rank)
          END IF
        END DO
      ELSE
        CALL mpi_isend (asend, npts, mp_float, mymaster, myrank+500,    &
     &                  mycomm, request, myerror)
        CALL mpi_wait (request, sstatus, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ISEND', myrank, serror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast reduced variables from process to all processes in the
!  group.
!
      CALL mpi_bcast (areduce, 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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# endif
 10   FORMAT (/,' MP_REDUCE_0D - error during ',a,' call, Task = ',     &
     &        i3.3,' Error = ',i3,/,16x,a)
!
!  Unpack.
!
      a=areduce
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 65, __line__, myfile)
# endif
!
      RETURN

mp_reduce_0dp()

subroutine distribute_mod::mp_reduce_0dp	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	asize,
		real(dp), intent(inout)	a,
		character (len=*), intent(in)	handle_op,
		integer, intent(in), optional	inpcomm )

Definition at line 6379 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects and reduces requested double precision        !
!  variables from all nodes in the group.  Then, it broadcasts         !
!  reduced variables to all nodes in the group.                        !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Asize      Number of scalar variables to reduce.                 !
!     A          Vector of scalar variables to reduce.                 !
!     handle_op  Reduction operation handle (string).  The following   !
!                  reduction operations are supported:                 !
!                  'MIN', 'MAX', 'SUM'                                 !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Vector of reduced scalar variables.                   !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Asize
 
      integer, intent(in), optional :: InpComm
!
      character (len=*), intent(in) :: handle_op
!
      real(dp), intent(inout) :: A
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, Npts, Serror
      integer :: handle, i, rank, request
 
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
 
      integer, dimension(MPI_STATUS_SIZE) :: Rstatus
      integer, dimension(MPI_STATUS_SIZE) :: Sstatus
!
      real(dp) :: Areduce
      real(dp) :: Asend
      real(dp), dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_reduce_0dp"
 
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 65, __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
!
!-----------------------------------------------------------------------
!  Collect and reduce requested scalar variables.
!-----------------------------------------------------------------------
!
!  Pack data to reduce.
!
      asend=a
      npts=1
!
!  Collect and reduce.
!
#  if defined REDUCE_ALLREDUCE
      IF (handle_op(1:3).eq.'MIN') THEN
        handle=mpi_min
      ELSE IF (handle_op(1:3).eq.'MAX') THEN
        handle=mpi_max
      ELSE IF (handle_op(1:3).eq.'SUM') THEN
        handle=mpi_sum
      END IF
      CALL mpi_allreduce (asend, areduce, npts, mp_double, handle,      &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
#  elif defined REDUCE_ALLGATHER
      CALL mpi_allgather (asend, npts, mp_double,                       &
     &                    arecv, npts, mp_double,                       &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
      areduce=arecv(0)
      DO rank=1,ntilei(ng)*ntilej(ng)-1
        IF (handle_op(1:3).eq.'MIN') THEN
          areduce=min(areduce,arecv(rank))
        ELSE IF (handle_op(1:3).eq.'MAX') THEN
          areduce=max(areduce,arecv(rank))
        ELSE IF (handle_op(1:3).eq.'SUM') THEN
          areduce=areduce+arecv(rank)
        END IF
      END DO
#  elif defined REDUCE_SENDRECV
      IF (myrank.eq.mymaster) THEN
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_irecv (arecv(rank), npts, mp_double, rank,           &
     &                    rank+500, mycomm, rrequest(rank),             &
     &                    myerror)
        END DO
        areduce=asend
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_wait (rrequest(rank), rstatus, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,10) 'MPI_IRECV', rank, rerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
          IF (handle_op(1:3).eq.'MIN') THEN
            areduce=min(areduce,arecv(rank))
          ELSE IF (handle_op(1:3).eq.'MAX') THEN
            areduce=max(areduce,arecv(rank))
          ELSE IF (handle_op(1:3).eq.'SUM') THEN
            areduce=areduce+arecv(rank)
          END IF
        END DO
      ELSE
        CALL mpi_isend (asend, npts, mp_double, mymaster, myrank+500,   &
     &                  mycomm, request, myerror)
        CALL mpi_wait (request, sstatus, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ISEND', myrank, serror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast reduced variables from process to all processes in the
!  group.
!
      CALL mpi_bcast (areduce, npts, mp_double, mymaster,               &
     &                mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
#  endif
 10   FORMAT (/,' MP_REDUCE_0DP - error during ',a,' call, Task = ',    &
     &        i3.3,' Error = ',i3,/,16x,a)
!
!  Unpack.
!
      a=areduce
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 65, __line__, myfile)
#  endif
!
      RETURN

mp_reduce_1d()

subroutine distribute_mod::mp_reduce_1d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	asize,
		real(r8), dimension(asize), intent(inout)	a,
		character (len=*), dimension(asize), intent(in)	handle_op,
		integer, intent(in), optional	inpcomm )

Definition at line 6981 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects and reduces requested variables from all      !
!  nodes in the group.  Then,  it broadcasts reduced variables to      !
!  all nodes in the group.                                             !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Asize      Number of scalar variables to reduce.                 !
!     A          Vector of scalar variables to reduce.                 !
!     handle_op  Reduction operation handle (string).  The following   !
!                  reduction operations are supported:                 !
!                  'MIN', 'MAX', 'SUM'                                 !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Vector of reduced scalar variables.                   !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Asize
 
      integer, intent(in), optional :: InpComm
!
      character (len=*), intent(in) :: handle_op(Asize)
!
      real(r8), intent(inout) :: A(Asize)
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, Serror
      integer :: handle, i, rank, request
 
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
 
      integer, dimension(MPI_STATUS_SIZE) :: Rstatus
      integer, dimension(MPI_STATUS_SIZE) :: Sstatus
!
      real(r8), dimension(Asize,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
      real(r8), dimension(Asize) :: Areduce
      real(r8), dimension(Asize) :: Asend
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_reduce_1d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 65, __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
!
!-----------------------------------------------------------------------
!  Collect and reduce requested scalar variables.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real((SIZE(arecv)+                   &
     &                                   2*asize)*kind(a),r8))
!
!  Pack data to reduce.
!
      DO i=1,asize
        asend(i)=a(i)
      END DO
!
!  Collect and reduce.
!
# if defined REDUCE_ALLREDUCE
      DO i=1,asize
        IF (handle_op(i)(1:3).eq.'MIN') THEN
          handle=mpi_min
        ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
          handle=mpi_max
        ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
          handle=mpi_sum
        END IF
        CALL mpi_allreduce (asend(i), areduce(i), 1, mp_float, handle,  &
     &                      mycomm, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror,           &
     &                      string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END DO
# elif defined REDUCE_ALLGATHER
      CALL mpi_allgather (asend, asize, mp_float,                       &
     &                    arecv, asize, mp_float,                       &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
      DO i=1,asize
        areduce(i)=arecv(i,0)
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          IF (handle_op(i)(1:3).eq.'MIN') THEN
            areduce(i)=min(areduce(i),arecv(i,rank))
          ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
            areduce(i)=max(areduce(i),arecv(i,rank))
          ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
            areduce(i)=areduce(i)+arecv(i,rank)
          END IF
        END DO
      END DO
# elif defined REDUCE_SENDRECV
      IF (myrank.eq.mymaster) THEN
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_irecv (arecv(1,rank), asize, mp_float, rank,         &
     &                    rank+500, mycomm, rrequest(rank), myerror)
        END DO
        DO i=1,asize
          areduce(i)=asend(i)
        END DO
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_wait (rrequest(rank), rstatus, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,10) 'MPI_IRECV', rank, rerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
          DO i=1,asize
            IF (handle_op(i)(1:3).eq.'MIN') THEN
              areduce(i)=min(areduce(i),arecv(i,rank))
            ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
              areduce(i)=max(areduce(i),arecv(i,rank))
            ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
              areduce(i)=areduce(i)+arecv(i,rank)
            END IF
          END DO
        END DO
      ELSE
        CALL mpi_isend (asend, asize, mp_float, mymaster, myrank+500,   &
     &                  mycomm, request, myerror)
        CALL mpi_wait (request, sstatus, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ISEND', myrank, serror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast reduced variables from process to all processes in the
!  group.
!
      CALL mpi_bcast (areduce, asize, 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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
# endif
 10   FORMAT (/,' MP_REDUCE_1D - error during ',a,' call, Task = ',     &
     &        i3.3,' Error = ',i3,/,16x,a)
!
!  Unpack.
!
      DO i=1,asize
        a(i)=areduce(i)
      END DO
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 65, __line__, myfile)
# endif
!
      RETURN

mp_reduce_1dp()

subroutine distribute_mod::mp_reduce_1dp	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	asize,
		real(dp), dimension(asize), intent(inout)	a,
		character (len=*), dimension(asize), intent(in)	handle_op,
		integer, intent(in), optional	inpcomm )

Definition at line 6574 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects and reduces requested double precision        !
!  variables from all nodes in the group.  Then, it broadcasts         !
!  reduced variables to all nodes in the group.                        !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Asize      Number of scalar variables to reduce.                 !
!     A          Vector of scalar variables to reduce.                 !
!     handle_op  Reduction operation handle (string).  The following   !
!                  reduction operations are supported:                 !
!                  'MIN', 'MAX', 'SUM'                                 !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Vector of reduced scalar variables.                   !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Asize
 
      integer, intent(in), optional :: InpComm
!
      character (len=*), intent(in) :: handle_op(Asize)
!
      real(dp), intent(inout) :: A(Asize)
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, Serror
      integer :: handle, i, rank, request
 
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
 
      integer, dimension(MPI_STATUS_SIZE) :: Rstatus
      integer, dimension(MPI_STATUS_SIZE) :: Sstatus
!
      real(dp), dimension(Asize,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
      real(dp), dimension(Asize) :: Areduce
      real(dp), dimension(Asize) :: Asend
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_reduce_1dp"
 
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 65, __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
!
!-----------------------------------------------------------------------
!  Collect and reduce requested scalar variables.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real((SIZE(arecv)+                   &
     &                                   2*asize)*kind(a),r8))
!
!  Pack data to reduce.
!
      DO i=1,asize
        asend(i)=a(i)
      END DO
!
!  Collect and reduce.
!
#  if defined REDUCE_ALLREDUCE
      DO i=1,asize
        IF (handle_op(i)(1:3).eq.'MIN') THEN
          handle=mpi_min
        ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
          handle=mpi_max
        ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
          handle=mpi_sum
        END IF
        CALL mpi_allreduce (asend(i), areduce(i), 1, mp_double, handle, &
     &                      mycomm, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror,           &
     &                      string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END DO
#  elif defined REDUCE_ALLGATHER
      CALL mpi_allgather (asend, asize, mp_double,                      &
     &                    arecv, asize, mp_double,                      &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
      DO i=1,asize
        areduce(i)=arecv(i,0)
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          IF (handle_op(i)(1:3).eq.'MIN') THEN
            areduce(i)=min(areduce(i),arecv(i,rank))
          ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
            areduce(i)=max(areduce(i),arecv(i,rank))
          ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
            areduce(i)=areduce(i)+arecv(i,rank)
          END IF
        END DO
      END DO
#  elif defined REDUCE_SENDRECV
      IF (myrank.eq.mymaster) THEN
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_irecv (arecv(1,rank), asize, mp_double, rank,        &
     &                    rank+500, mycomm, rrequest(rank),             &
     &                    myerror)
        END DO
        DO i=1,asize
          areduce(i)=asend(i)
        END DO
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_wait (rrequest(rank), rstatus, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,10) 'MPI_IRECV', rank, rerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
          DO i=1,asize
            IF (handle_op(i)(1:3).eq.'MIN') THEN
              areduce(i)=min(areduce(i),arecv(i,rank))
            ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
              areduce(i)=max(areduce(i),arecv(i,rank))
            ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
              areduce(i)=areduce(i)+arecv(i,rank)
            END IF
          END DO
        END DO
      ELSE
        CALL mpi_isend (asend, asize, mp_double, mymaster, myrank+500,  &
     &                  mycomm, request, myerror)
        CALL mpi_wait (request, sstatus, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ISEND', myrank, serror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast reduced variables from process to all processes in the
!  group.
!
      CALL mpi_bcast (areduce, asize, mp_double, mymaster,              &
     &                mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
#  endif
 10   FORMAT (/,' MP_REDUCE_1DP - error during ',a,' call, Task = ',    &
     &        i3.3,' Error = ',i3,/,16x,a)
!
!  Unpack.
!
      DO i=1,asize
        a(i)=areduce(i)
      END DO
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 65, __line__, myfile)
#  endif
!
      RETURN

mp_reduce_i8()

subroutine distribute_mod::mp_reduce_i8	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	asize,
		integer(i8b), dimension(asize), intent(inout)	a,
		character (len=*), dimension(asize), intent(in)	handle_op,
		integer, intent(in), optional	inpcomm )

Definition at line 6167 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine collects and reduces requested 1D integer array        !
!  variables from all nodes in the group.                              !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Asize      Number of scalar variables to reduce.                 !
!     A          Vector of scalar variables to reduce.                 !
!     handle_op  Reduction operation handle (string).  The following   !
!                  reduction operations are supported:                 !
!                  'MIN', 'MAX', 'SUM'                                 !
!     InpComm    Communicator handle (integer, OPTIONAL).              !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Vector of reduced scalar variables.                   !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, Asize
 
      integer, intent(in), optional :: InpComm
!
      character (len=*), intent(in) :: handle_op(Asize)
!
      integer(i8b), intent(inout) :: A(Asize)
!
!  Local variable declarations.
!
      integer :: Lstr, MyCOMM, MyError, Serror
      integer :: handle, i, rank, request
 
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
 
      integer, dimension(MPI_STATUS_SIZE) :: Rstatus
      integer, dimension(MPI_STATUS_SIZE) :: Sstatus
!
      integer(i8b), dimension(Asize,0:NtileI(ng)*NtileJ(ng)-1) :: Arecv
      integer(i8b), dimension(Asize) :: Areduce
      integer(i8b), dimension(Asize) :: Asend
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_reduce_1di"
 
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 65, __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
!
!-----------------------------------------------------------------------
!  Collect and reduce requested scalar variables.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real((SIZE(arecv)+                   &
     &                                   2*asize)*kind(a),r8))
!
!  Pack data to reduce.
!
      DO i=1,asize
        asend(i)=a(i)
      END DO
!
!  Collect and reduce.
!
#  if defined REDUCE_ALLREDUCE
      DO i=1,asize
        IF (handle_op(i)(1:3).eq.'MIN') THEN
          handle=mpi_min
        ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
          handle=mpi_max
        ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
          handle=mpi_sum
        END IF
        CALL mpi_allreduce (asend(i), areduce(i), 1, mpi_integer,       &
     &                      handle, mycomm, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ALLREDUCE', myrank, myerror,           &
     &                      string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END DO
#  elif defined REDUCE_ALLGATHER
      CALL mpi_allgather (asend, asize, mpi_integer,                    &
     &                    arecv, asize, mpi_integer,                    &
     &                    mycomm, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_ALLGATHER', myrank, myerror,             &
     &                    string(1:lstr)
        exit_flag=2
        RETURN
      END IF
      DO i=1,asize
        areduce(i)=arecv(i,0)
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          IF (handle_op(i)(1:3).eq.'MIN') THEN
            areduce(i)=min(areduce(i),arecv(i,rank))
          ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
            areduce(i)=max(areduce(i),arecv(i,rank))
          ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
            areduce(i)=areduce(i)+arecv(i,rank)
          END IF
        END DO
      END DO
#  elif defined REDUCE_SENDRECV
      IF (myrank.eq.mymaster) THEN
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_irecv (arecv(1,rank), asize, mpi_integer, rank,      &
     &                    rank+500, mycomm, rrequest(rank),             &
     &                    myerror)
        END DO
        DO i=1,asize
          areduce(i)=asend(i)
        END DO
        DO rank=1,ntilei(ng)*ntilej(ng)-1
          CALL mpi_wait (rrequest(rank), rstatus, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,10) 'MPI_IRECV', rank, rerror, string(1:lstr)
            exit_flag=2
            RETURN
          END IF
          DO i=1,asize
            IF (handle_op(i)(1:3).eq.'MIN') THEN
              areduce(i)=min(areduce(i),arecv(i,rank))
            ELSE IF (handle_op(i)(1:3).eq.'MAX') THEN
              areduce(i)=max(areduce(i),arecv(i,rank))
            ELSE IF (handle_op(i)(1:3).eq.'SUM') THEN
              areduce(i)=areduce(i)+arecv(i,rank)
            END IF
          END DO
        END DO
      ELSE
        CALL mpi_isend (asend, asize, mpi_integer, mymaster,            &
     &                  myrank+500, mycomm, request, myerror)
        CALL mpi_wait (request, sstatus, myerror)
        IF (myerror.ne.mpi_success) THEN
          CALL mpi_error_string (myerror, string, lstr, serror)
          lstr=len_trim(string)
          WRITE (stdout,10) 'MPI_ISEND', myrank, serror, string(1:lstr)
          exit_flag=2
          RETURN
        END IF
      END IF
!
!  Broadcast reduced variables from process to all processes in the
!  group.
!
      CALL mpi_bcast (areduce, asize, 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,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
#  endif
 10   FORMAT (/,' MP_REDUCE_I8 - error during ',a,' call, Task = ',     &
     &        i3.3,' Error = ',i3,/,16x,a)
!
!  Unpack.
!
      DO i=1,asize
        a(i)=areduce(i)
      END DO
#  ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 65, __line__, myfile)
#  endif
!
      RETURN

mp_scatter2d()

subroutine distribute_mod::mp_scatter2d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	lbi,
		integer, intent(in)	ubi,
		integer, intent(in)	lbj,
		integer, intent(in)	ubj,
		integer, intent(in)	nghost,
		integer, intent(in)	gtype,
		real(r8), intent(inout)	amin,
		real(r8), intent(inout)	amax,
		integer, intent(in)	nwpts,
		integer, dimension(nwpts), intent(in)	ij_water,
		integer, intent(in)	npts,
		real(r8), dimension(npts+2), intent(inout)	a,
		real(r8), dimension(lbi:ubi,lbj:ubj), intent(out)	awrk )

Definition at line 7323 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine scatters input global data, packed as 1D real array,   !
!  to each tiled array.  Because this routine is also used by the      !
!  adjoint model,  the ghost-points in the halo region are NOT updated !
!  in the ouput tile array (Awrk).  It is used by the  master node  to !
!  distribute date read from NetCDF files during serial I/O.           !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     LBi        I-dimension Lower bound.                              !
!     UBi        I-dimension Upper bound.                              !
!     LBj        J-dimension Lower bound.                              !
!     UBj        J-dimension Upper bound.                              !
!     Nghost     Number of ghost-points in the halo region.            !
!     gtype      C-grid type. If negative and Land-Sea mask is         !
!                  available, only water-points are processed.         !
!     Amin       Input array minimum value.                            !
!     Amax       Input array maximum value.                            !
!     NWpts      Number of water points.                               !
!     IJ_water   IJ-indices for water points.                          !
!     Npts       Number of points to processes in A.                   !
!     A          Input global data from each node packed into 1D array !
!                  in column-major order. That is, in the same way     !
!                  that Fortran multi-dimensional arrays are stored    !
!                  in memory. Only valid on root task, MyMaster.       !
!     Npts       Number of points to processes in A.                   !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Awrk       2D tiled, floating-point array.                       !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
      integer, intent(in) :: LBi, UBi, LBj, UBj
      integer, intent(in) :: Nghost, gtype, Npts
 
# if defined READ_WATER && defined MASKING
      integer, intent(in) :: NWpts
      integer, intent(in) :: IJ_water(NWpts)
# endif
!
      real(r8), intent(inout) :: Amin, Amax
      real(r8), intent(inout) :: A(Npts+2)
      real(r8), intent(out)   :: Awrk(LBi:UBi,LBj:UBj)
!
!  Local variable declarations.
!
      integer :: Io, Ie, Jo, Je, Ioff, Joff
      integer :: Imin, Imax, Jmin, Jmax
      integer :: iLB, iUB, jLB, jUB
      integer :: Isize, Jsize, IJsize, Vsize
      integer :: Lstr, MyError, MySize, MyType, Ntasks, Serror, ghost
      integer :: Cgrid, i, ic, ij, j, jc, mc, nc, rank
!
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: counts, displs
!
# ifndef SCATTER_BCAST
      integer, allocatable :: ij_global(:,:)
!
      real(r8) :: Astats(2)
      real(r8), allocatable :: Vrecv(:)
      real(r8), dimension(Npts) :: Vreset 
# endif
      real(r8), dimension(Npts+2) :: Vglobal
!
      character (len=10) :: MyMethod
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_scatter2d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 67, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Set horizontal starting and ending indices for parallel domain
!  partitions in the XI- and ETA-directions.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real(SIZE(vglobal)*kind(a),r8))
!
!  Set full grid first and last point according to staggered C-grid
!  classification. Notice that the offsets are for the private array
!  counter.
!
      mytype=abs(gtype)
 
      SELECT CASE (mytype)
        CASE (p2dvar, p3dvar)
          io=iobounds(ng) % ILB_psi
          ie=iobounds(ng) % IUB_psi
          jo=iobounds(ng) % JLB_psi
          je=iobounds(ng) % JUB_psi
          ioff=0
          joff=1
        CASE (r2dvar, r3dvar)
          io=iobounds(ng) % ILB_rho
          ie=iobounds(ng) % IUB_rho
          jo=iobounds(ng) % JLB_rho
          je=iobounds(ng) % JUB_rho
          ioff=1
          joff=0
        CASE (u2dvar, u3dvar)
          io=iobounds(ng) % ILB_u
          ie=iobounds(ng) % IUB_u
          jo=iobounds(ng) % JLB_u
          je=iobounds(ng) % JUB_u
          ioff=0
          joff=0
        CASE (v2dvar, v3dvar)
          io=iobounds(ng) % ILB_v
          ie=iobounds(ng) % IUB_v
          jo=iobounds(ng) % JLB_v
          je=iobounds(ng) % JUB_v
          ioff=1
          joff=1
        CASE DEFAULT                              ! RHO-points
          io=iobounds(ng) % ILB_rho
          ie=iobounds(ng) % IUB_rho
          jo=iobounds(ng) % JLB_rho
          je=iobounds(ng) % JUB_rho
          ioff=1
          joff=0
      END SELECT
!
      isize=ie-io+1
      jsize=je-jo+1
      ijsize=isize*jsize
!
!  Set Scatter counts and displacement vectors. Use non-overlapping
!  (ghost=0) ranges according to tile rank in 'mpi_scatterv' to work
!  correctly.
!
      ghost=0                                     ! non-overlapping
!
      SELECT CASE (mytype)
        CASE (p2dvar, p3dvar)
          cgrid=1
        CASE (r2dvar, r3dvar)
          cgrid=2
        CASE (u2dvar, u3dvar)
          cgrid=3
        CASE (v2dvar, v3dvar)
          cgrid=4
        CASE DEFAULT                              ! RHO-points
          cgrid=2
      END SELECT
!
      ntasks=ntilei(ng)*ntilej(ng)
      nc=0
      DO rank=0,ntasks-1
        ilb=bounds(ng) % Imin(cgrid,ghost,rank)
        iub=bounds(ng) % Imax(cgrid,ghost,rank)
        jlb=bounds(ng) % Jmin(cgrid,ghost,rank)
        jub=bounds(ng) % Jmax(cgrid,ghost,rank)
        displs(rank)=nc
        DO j=jlb,jub
          DO i=ilb,iub
            nc=nc+1
          END DO
        END DO
        counts(rank)=nc-displs(rank)
      END DO
!
!  Load global data into send buffer, Vglobal, which is only known by
!  the root process at this point. If water points input data, fill
!  land points.
!
      vglobal=0.0_r8
      vsize=npts
!
      IF (myrank.eq.mymaster) Then
        IF (gtype.gt.0) THEN
          vglobal(1:vsize)=a(1:vsize)
# if defined READ_WATER && defined MASKING
        ELSE
          ij=0
          mc=0
          nc=0
          DO j=jo,je
            jc=(j-joff)*isize
            DO i=io,ie
              ij=ij+1
              ic=i+ioff+jc
              IF (ij_water(mc+1).eq.ij) THEN
                mc=mc+1
                nc=nc+1
                vglobal(ic)=a(nc)
              ELSE
                vglobal(ic)=0.0_r8
              END IF
            END DO
          END DO
          vsize=ic
#  endif
        END IF
      END IF
!
!-----------------------------------------------------------------------
!  Scatter requested global data.
!-----------------------------------------------------------------------
 
# ifdef SCATTER_BCAST
!
!  Set tile range to include overlapping halos, if requested.
!
      IF (nghost.eq.0) THEN
        ghost=0                                   ! non-overlapping
      ELSE
        ghost=1                                   ! overlapping
      END IF
      imin=bounds(ng) % Imin(cgrid,ghost,myrank)
      imax=bounds(ng) % Imax(cgrid,ghost,myrank)
      jmin=bounds(ng) % Jmin(cgrid,ghost,myrank)
      jmax=bounds(ng) % Jmax(cgrid,ghost,myrank)
!
!  Append Min/Max values since they are only known by root process
!
      IF (myrank.eq.mymaster) Then
        vglobal(vsize+1)=amin
        vglobal(vsize+2)=amax
      END IF
      vsize=vsize+2
!
!  Broadcast data to all processes in the group, itself included.
!
      CALL mpi_bcast (vglobal, vsize, mp_float, mymaster,               &
     &                ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, trim(string)
 10     FORMAT (/,' ROMS_SCATTER2D - error during ',a,                  &
     &          ' call, Task = ', i3.3, ' Error = ',i3,/,15x,a)
        exit_flag=2
        RETURN
      END IF
!
! Unpack data buffer and load into tiled array.
!
      DO j=jmin, jmax
        jc=(j-joff)*isize
        DO i=imin, imax
          ic=i+ioff+jc
          awrk(i,j)=vglobal(ic)
        END DO
      END DO
      amin=vglobal(vsize-1)
      amax=vglobal(vsize)
 
# else
!
!  Set tile range for non-overlapping tiles.
!
      ghost=0                                     ! non-overlapping
      imin=bounds(ng) % Imin(cgrid,ghost,myrank)
      imax=bounds(ng) % Imax(cgrid,ghost,myrank)
      jmin=bounds(ng) % Jmin(cgrid,ghost,myrank)
      jmax=bounds(ng) % Jmax(cgrid,ghost,myrank)
!
!  If master node, set (i,j) indices map from global array to vector.
!
      IF (myrank.eq.mymaster) THEN
        allocate ( ij_global(io:ie,jo:je) )
!
        DO j=jo,je
          jc=(j-joff)*isize
          DO i=io,ie
            ij=i+ioff+jc
            ij_global(i,j)=ij
          END DO
        END DO
!
!  Reorganize the input global vector in such a way that the tiled data
!  is continuous in memory to facilitate "SCATTERV" with different size
!  sections.
!
        nc=0
        DO rank=0,ntasks-1
          ilb=bounds(ng) % Imin(cgrid,ghost,rank)
          iub=bounds(ng) % Imax(cgrid,ghost,rank)
          jlb=bounds(ng) % Jmin(cgrid,ghost,rank)
          jub=bounds(ng) % Jmax(cgrid,ghost,rank)
          DO j=jlb,jub
            DO i=ilb,iub
              ij=ij_global(i,j)
              nc=nc+1
              vreset(nc)=vglobal(ij)
            END DO
          END DO
        END DO
        deallocate (ij_global)
      END IF
!
!  Scatter global data to local tiled arrays.
!
      mysize=(imax-imin+1)*(jmax-jmin+1)
      allocate ( vrecv(mysize) )
      vrecv=0.0_r8
!
      CALL mpi_scatterv (vreset, counts, displs, mp_float,              &
     &                   vrecv, mysize, mp_float,                       &
     &                   mymaster, ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        WRITE (stdout,20) 'MPI_SCATTERV', myrank, myerror,              &
     &                    trim(string)
 20     FORMAT (/,' MP_SCATTER2D - error during ',a,                    &
     &          ' call, Task = ', i3.3, ' Error = ',i3,/,15x,a)
        exit_flag=2
        RETURN
      END IF
!
!  Unpack data buffer and load into tiled array
!
      nc=0
      DO j=jmin,jmax
        DO i=imin,imax
          nc=nc+1          
          awrk(i,j)=vrecv(nc)
        END DO
      END DO
      deallocate ( vrecv )
!
!  If requested, include halo exchanges.
!
      IF (nghost.gt.0) THEN
        CALL mp_exchange2d (ng, myrank, model, 1,                       &
     &                      lbi, ubi, lbj, ubj,                         &
     &                      nghostpoints,                               &
     &                      ewperiodic(ng), nsperiodic(ng),             &
     &                      awrk)
      END IF
!
!  Broadcast global Min/Max values to all tasks in the group since they
!  are only known by root.
!
      astats(1)=amin
      astats(2)=amax
      mysize=2
!
      CALL mpi_bcast (astats, mysize, mp_float, mymaster,               &
     &                ocn_comm_world,  myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        WRITE (stdout,30) 'MPI_BCAST', myrank, myerror, trim(string)
 30     FORMAT (/,' MP_SCATTER2D - error during ',a,' call, Task = ',   &
     &          i3.3, ' Error = ',i3,/,15x,a)
        exit_flag=2
        RETURN
      END IF
!
      amin=astats(1)
      amax=astats(2)
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 67, __line__, myfile)
# endif
!
      RETURN

References mod_param::bmemmax, mod_param::bounds, mod_scalars::ewperiodic, mod_scalars::exit_flag, mod_param::iobounds, mp_exchange_mod::mp_exchange2d(), mod_parallel::mp_float, mod_parallel::mymaster, mod_parallel::myrank, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_param::p2dvar, mod_param::p3dvar, mod_param::r2dvar, mod_param::r3dvar, mod_iounits::stdout, mod_param::u2dvar, mod_param::u3dvar, mod_param::v2dvar, mod_param::v3dvar, wclock_off(), and wclock_on().

Referenced by nf_fread2d_mod::nf_fread2d::nf90_fread2d(), nf_fread3d_mod::nf_fread3d::nf90_fread3d(), nf_fread4d_mod::nf_fread4d::nf90_fread4d(), and white_noise_mod::white_noise2d().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_scatter3d()

subroutine distribute_mod::mp_scatter3d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	lbi,
		integer, intent(in)	ubi,
		integer, intent(in)	lbj,
		integer, intent(in)	ubj,
		integer, intent(in)	lbk,
		integer, intent(in)	ubk,
		integer, intent(in)	nghost,
		integer, intent(in)	gtype,
		real(r8), intent(inout)	amin,
		real(r8), intent(inout)	amax,
		integer, intent(in)	nwpts,
		integer, dimension(nwpts), intent(in)	ij_water,
		integer, intent(in)	npts,
		real(r8), dimension(npts+2), intent(inout)	a,
		real(r8), dimension(lbi:ubi,lbj:ubj,lbk:ubk), intent(out)	awrk )

Definition at line 8088 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine broadcasts input global data, packed as 1D real array, !
!  to each tiled array.  Because this routine is also used by the      !
!  adjoint model,  the ghost-points in the halo region are NOT updated !
!  in the ouput tile array (Awrk).  It is used by the  master node  to !
!  scatter input global data to each tiled node.                       !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     LBi        I-dimension Lower bound.                              !
!     UBi        I-dimension Upper bound.                              !
!     LBj        J-dimension Lower bound.                              !
!     UBj        J-dimension Upper bound.                              !
!     LBk        K-dimension Lower bound.                              !
!     UBk        K-dimension Upper bound.                              !
!     Nghost     Number of ghost-points in the halo region.            !
!     gtype      C-grid type. If negative and Land-Sea mask is         !
!                  available, only water-points are processed.         !
!     Amin       Input array minimum value.                            !
!     Amax       Input array maximum value.                            !
!     NWpts      Number of water points.                               !
!     IJ_water   IJ-indices for water points.                          !
!     Npts       Number of points to processes in A.                   !
!     A          Input global data from each node packed into 1D array !
!                  in column-major order. That is, in the same way     !
!                  that Fortran multi-dimensional arrays are stored    !
!                  in memory. Only valid on root task, MyMaster.       !
!     Npts       Number of points to processes in A.                   !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     Awrk       3D tiled, floating-point array.                       !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
      integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
      integer, intent(in) :: Nghost, gtype, Npts
 
# if defined READ_WATER && defined MASKING
      integer, intent(in) :: NWpts
      integer, intent(in) :: IJ_water(NWpts)
# endif
!
      real(r8), intent(inout) :: Amin, Amax
      real(r8), intent(inout) :: A(Npts+2)
      real(r8), intent(out)   :: Awrk(LBi:UBi,LBj:UBj,LBk:UBk)
!
!  Local variable declarations.
!
      integer :: Io, Ie, Jo, Je, Ioff, Joff, Koff
      integer :: Imin, Imax, Jmin, Jmax
      integer :: iLB, iUB, jLB, jUB
      integer :: Isize, Jsize, Ksize, IJsize, Vsize, Vsize2d
      integer :: Lstr, MyError, MySize, MyType, Ntasks, Serror, ghost
      integer :: Cgrid, i, ic, ij, ijk, j, jc, k, kc, mc, nc, rank
!
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: counts, displs
!
# ifndef SCATTER_BCAST
      integer, allocatable :: ijk_global(:,:,:)
!
      real(r8) :: Astats(2)
      real(r8), allocatable :: Vrecv(:)
      real(r8), dimension(Npts) :: Vreset 
# endif
      real(r8), dimension(Npts+2) :: Vglobal
!
      character (len=10) :: MyMethod
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_scatter3d"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 67, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Set horizontal starting and ending indices for parallel domain
!  partitions in the XI- and ETA-directions.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real(SIZE(vglobal)*kind(a),r8))
!
!  Set full grid first and last point according to staggered C-grid
!  classification. Notice that the offsets are for the private array
!  counters.
!
      mytype=abs(gtype)
 
      SELECT CASE (mytype)
        CASE (p2dvar, p3dvar)
          io=iobounds(ng) % ILB_psi
          ie=iobounds(ng) % IUB_psi
          jo=iobounds(ng) % JLB_psi
          je=iobounds(ng) % JUB_psi
          ioff=0
          joff=1
        CASE (r2dvar, r3dvar)
          io=iobounds(ng) % ILB_rho
          ie=iobounds(ng) % IUB_rho
          jo=iobounds(ng) % JLB_rho
          je=iobounds(ng) % JUB_rho
          ioff=1
          joff=0
        CASE (u2dvar, u3dvar)
          io=iobounds(ng) % ILB_u
          ie=iobounds(ng) % IUB_u
          jo=iobounds(ng) % JLB_u
          je=iobounds(ng) % JUB_u
          ioff=0
          joff=0
        CASE (v2dvar, v3dvar)
          io=iobounds(ng) % ILB_v
          ie=iobounds(ng) % IUB_v
          jo=iobounds(ng) % JLB_v
          je=iobounds(ng) % JUB_v
          ioff=1
          joff=1
        CASE DEFAULT                              ! RHO-points
          io=iobounds(ng) % ILB_rho
          ie=iobounds(ng) % IUB_rho
          jo=iobounds(ng) % JLB_rho
          je=iobounds(ng) % JUB_rho
          ioff=1
          joff=0
      END SELECT
 
      IF (lbk.eq.0) THEN
        koff=0
      ELSE
        koff=1
      END IF
 
      isize=ie-io+1
      jsize=je-jo+1
      ksize=ubk-lbk+1
      ijsize=isize*jsize
!
!  Set Scatter counts and displacement vectors. Use non-overlapping
!  (ghost=0) ranges according to tile rank in 'mpi_scatterv' to work
!  correctly.
!
      ghost=0                                     ! non-overlapping
!
      SELECT CASE (mytype)
        CASE (p2dvar, p3dvar)
          cgrid=1
        CASE (r2dvar, r3dvar)
          cgrid=2
        CASE (u2dvar, u3dvar)
          cgrid=3
        CASE (v2dvar, v3dvar)
          cgrid=4
        CASE DEFAULT                              ! RHO-points
          cgrid=2
      END SELECT
!
      ntasks=ntilei(ng)*ntilej(ng)
      nc=0
      DO rank=0,ntasks-1
        ilb=bounds(ng) % Imin(cgrid,ghost,rank)
        iub=bounds(ng) % Imax(cgrid,ghost,rank)
        jlb=bounds(ng) % Jmin(cgrid,ghost,rank)
        jub=bounds(ng) % Jmax(cgrid,ghost,rank)
        displs(rank)=nc
        DO k=lbk,ubk
          DO j=jlb,jub
            DO i=ilb,iub
              nc=nc+1
            END DO
          END DO
        END DO
        counts(rank)=nc-displs(rank)
      END DO
!
!  Load global data into send buffer, Vglobal, which is only known by
!  the root process at this point. If water points input data, fill
!  land points.
!
      vglobal=0.0_r8
      vsize=npts
!
      IF (myrank.eq.mymaster) Then
        IF (gtype.gt.0) THEN
          vglobal(1:vsize)=a(1:vsize)
# if defined READ_WATER && defined MASKING
        ELSE
          nc=0
          DO k=lbk,ubk
            kc=(k-koff)*ijsize
            ij=0
            mc=0
            DO j=jo,je
              jc=(j-joff)*isize
              DO i=io,ie 
                ij=ij+1
                ic=i+ioff+jc+kc
                IF (ij_water(mc+1).eq.ij) THEN
                  mc=mc+1
                  nc=nc+1
                  vglobal(ic)=a(nc)
                ELSE
                  vglobal(ic)=0.0_r8
                END IF
              END DO
            END DO
          END DO
          vsize=ic
# endif
        END IF
      END IF
!
!-----------------------------------------------------------------------
!  Scatter requested array data.
!-----------------------------------------------------------------------
 
# ifdef SCATTER_BCAST
!
!  Set tile range to include overlapping halos, if requested.
!
      IF (nghost.eq.0) THEN
        ghost=0                                   ! non-overlapping
      ELSE
        ghost=1                                   ! overlapping
      END IF
      imin=bounds(ng) % Imin(cgrid,ghost,myrank)
      imax=bounds(ng) % Imax(cgrid,ghost,myrank)
      jmin=bounds(ng) % Jmin(cgrid,ghost,myrank)
      jmax=bounds(ng) % Jmax(cgrid,ghost,myrank)
!
!  Append Min/Max values since they are only known by root.
!
      IF (myrank.eq.mymaster) Then
        vglobal(vsize+1)=amin
        vglobal(vsize+2)=amax
      END IF
      vsize=vsize+2
!
!  Broadcast data to all processes in the group, itself included.
!
      CALL mpi_bcast (vglobal, vsize, mp_float, mymaster,               &
     &                ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, trim(string)
 10     FORMAT (/,' MP_SCATTER3D - error during ',a,                    &
     &          ' call, Task = ', i3.3, ' Error = ',i3,/,15x,a)
        exit_flag=2
        RETURN
      END IF
!
! Unpack data buffer and load into tiled array.
!
      DO k=lbk,ubk
        kc=(k-koff)*isize*jsize
        DO j=jmin,jmax
          jc=(j-joff)*isize
          DO i=imin,imax
            ic=i+ioff+jc+kc
            awrk(i,j,k)=vglobal(ic)
          END DO
        END DO
      END DO
      amin=vglobal(vsize-1)
      amax=vglobal(vsize)
 
# else
!
!  Set tile range for non-overlapping tiles.
!
      ghost=0                                     ! non-overlapping
      imin=bounds(ng) % Imin(cgrid,ghost,myrank)
      imax=bounds(ng) % Imax(cgrid,ghost,myrank)
      jmin=bounds(ng) % Jmin(cgrid,ghost,myrank)
      jmax=bounds(ng) % Jmax(cgrid,ghost,myrank)
!
!  If mater node, Set (i,j,k) indices map from global array to vector.
!
      IF (myrank.eq.mymaster) THEN
        allocate ( ijk_global(io:ie,jo:je,lbk:ubk) )
!
        DO k=lbk,ubk
          kc=(k-koff)*ijsize
          DO j=jo,je
            jc=(j-joff)*isize
            DO i=io,ie
              ijk=i+ioff+jc+kc
              ijk_global(i,j,k)=ijk
            END DO
          END DO
        END DO
!
!  Reorganize the input global vector in such a way that the tile data
!  is continuous in memory to facilitate "SCATTERV" with different size
!  sections.
!
        nc=0
        DO rank=0,ntasks-1
          ilb=bounds(ng) % Imin(cgrid,ghost,rank)
          iub=bounds(ng) % Imax(cgrid,ghost,rank)
          jlb=bounds(ng) % Jmin(cgrid,ghost,rank)
          jub=bounds(ng) % Jmax(cgrid,ghost,rank)
          DO k=lbk,ubk
            DO j=jlb,jub
              DO i=ilb,iub
                ijk=ijk_global(i,j,k)
                nc=nc+1
                vreset(nc)=vglobal(ijk)
              END DO
            END DO
          END DO
        END DO
        deallocate (ijk_global)
      END IF
!
!  Distribute global data into local tiled arrays.
!
      mysize=(imax-imin+1)*(jmax-jmin+1)*(ubk-lbk+1)
      allocate ( vrecv(mysize) )
      vrecv=0.0_r8
!
      CALL mpi_scatterv (vreset, counts, displs, mp_float,              &
     &                   vrecv, mysize, mp_float,                       &
     &                   mymaster, ocn_comm_world, myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        WRITE (stdout,20) 'MPI_SCATTERV', myrank, myerror,              &
     &                    trim(string)
 20     FORMAT (/,' MP_SCATTER3D - error during ',a,                    &
     &          ' call, Task = ', i3.3, ' Error = ',i3,/,15x,a)
        exit_flag=2
        RETURN
      END IF
!
!  Unpack data buffer and load into tiled array
!
      nc=0
      DO k=lbk,ubk
        DO j=jmin,jmax
          DO i=imin,imax
            nc=nc+1          
            awrk(i,j,k)=vrecv(nc)
          END DO
        END DO
      END DO
      deallocate ( vrecv )
!
!  If requested, include halo exchanges.
!
      IF (nghost.gt.0) THEN
        CALL mp_exchange3d (ng, myrank, model, 1,                       &
     &                      lbi, ubi, lbj, ubj, lbk, ubk,               &
     &                      nghostpoints,                               &
     &                      ewperiodic(ng), nsperiodic(ng),             &
     &                      awrk)
      END IF
!
!  Broadcast global Min/Max values to all tasks in the group since they
!  are only known by root.
!
      astats(1)=amin
      astats(2)=amax
      mysize=2
!
      CALL mpi_bcast (astats, mysize, mp_float, mymaster,               &
     &                ocn_comm_world,  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, trim(string)
 30     FORMAT (/,' MP_SCATTER3D - error during ',a,' call, Task = ',   &
     &          i3.3, ' Error = ',i3,/,15x,a)
        exit_flag=2
        RETURN
      END IF
!
      amin=astats(1)
      amax=astats(2)
# endif
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 67, __line__, myfile)
# endif
!
      RETURN

References mod_param::bmemmax, mod_param::bounds, mod_scalars::ewperiodic, mod_scalars::exit_flag, mod_param::iobounds, mp_exchange_mod::mp_exchange3d(), mod_parallel::mp_float, mod_parallel::mymaster, mod_parallel::myrank, mod_param::nghostpoints, mod_scalars::nsperiodic, mod_param::ntilei, mod_param::ntilej, mod_parallel::ocn_comm_world, mod_param::p2dvar, mod_param::p3dvar, mod_param::r2dvar, mod_param::r3dvar, mod_iounits::stdout, mod_param::u2dvar, mod_param::u3dvar, mod_param::v2dvar, mod_param::v3dvar, wclock_off(), and wclock_on().

Referenced by nf_fread3d_mod::nf_fread3d::nf90_fread3d(), nf_fread4d_mod::nf_fread4d::nf90_fread4d(), and white_noise_mod::white_noise3d().

Here is the call graph for this function:

Here is the caller graph for this function:

mp_scatter_state()

subroutine distribute_mod::mp_scatter_state	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	mstr,
		integer, intent(in)	mend,
		integer, intent(in)	asize,
		real(r8), dimension(asize), intent(inout)	a,
		real(r8), dimension(mstr:mend), intent(out)	awrk )

Definition at line 8500 of file distribute.F.

!
!***********************************************************************
!                                                                      !
!  This routine scatters (global to threaded) state data to all nodes  !
!  in the group. Before this can be done, the global data needs to be  !
!  collected from all the  nodes  by the master.  This is achieved by  !
!  summing the input values at each point.  This  routine  is used to  !
!  pack the state data for the GST analysis propagators.               !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng         Nested grid number.                                   !
!     model      Calling model identifier.                             !
!     Mstr       Threaded array lower bound.                           !
!     Mend       Threaded array upper bound.                           !
!     Asize      Size of array A.                                      !
!     A          Threaded 1D array process.                            !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     A          Collected data from all nodes.                        !
!     Awrk       Threaded block of data.                               !
!                                                                      !
!***********************************************************************
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model
      integer, intent(in) :: Mstr, Mend, Asize
!
      real(r8), intent(inout)  :: A(Asize)
 
      real(r8), intent(out) :: Awrk(Mstr:Mend)
!
!  Local variable declarations.
!
      integer :: Lstr, MyError, Serror
      integer :: i, rank, request
 
      integer, dimension(0:NtileI(ng)*NtileJ(ng)-1) :: Rrequest
 
      integer, dimension(MPI_STATUS_SIZE) :: status
!
      real(r8), allocatable :: Arecv(:)
!
      character (len=MPI_MAX_ERROR_STRING) :: string
 
      character (len=*), parameter :: MyFile =                          &
     &  __FILE__//", mp_scatter_state"
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn on time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_on (ng, model, 67, __line__, myfile)
# endif
!
!-----------------------------------------------------------------------
!  Collect data blocks from all nodes and scatter the data to all nodes.
!-----------------------------------------------------------------------
!
!  Maximum automatic buffer memory size in bytes.
!
      bmemmax(ng)=max(bmemmax(ng), real(asize*kind(a),r8))
!
!  All nodes have distinct pieces of the data and zero everywhere else.
!  So the strategy here is for the master node to receive the data from
!  the other nodes (excluding itself) and accumulate the sum at each
!  point. Then, the master node broadcast (itself included) its copy of
!  the accumlated data to other the nodes in the group. After this, each
!  node loads only the required block of the data into output array.
!
!  Notice that only the master node allocates the recieving buffer
!  (Arecv). It also receives only buffer at the time to avoid having
!  a very large communication array.  So here memory is more important
!  than time.
!
      IF (myrank.eq.mymaster) THEN
!
!  If master node, allocate and receive buffer.
!
        IF (.not.allocated(arecv)) THEN
          allocate (arecv(asize))
        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, asize, mp_float, rank, rank+5,         &
     &                    ocn_comm_world, rrequest(rank), myerror)
          CALL mpi_wait (rrequest(rank), status, myerror)
          IF (myerror.ne.mpi_success) THEN
            CALL mpi_error_string (myerror, string, lstr, serror)
            lstr=len_trim(string)
            WRITE (stdout,10) 'MPI_IRECV', rank, myerror, string(1:lstr)
 10         FORMAT (/,' MP_SCATTER_STATE - error during ',a,            &
     &              ' call, Task = ', i3.3,' Error = ',i3,/,13x,a)
            exit_flag=2
            RETURN
          END IF
          DO i=1,asize
            a(i)=a(i)+arecv(i)
          END DO
        END DO
!
!  Otherwise, send data to master node.
!
      ELSE
        CALL mpi_isend (a, asize, mp_float, mymaster, myrank+5,         &
     &                  ocn_comm_world, 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,10) '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, asize, mp_float, mymaster, ocn_comm_world,     &
     &                myerror)
      IF (myerror.ne.mpi_success) THEN
        CALL mpi_error_string (myerror, string, lstr, serror)
        lstr=len_trim(string)
        WRITE (stdout,10) 'MPI_BCAST', myrank, myerror, string(1:lstr)
        exit_flag=2
        RETURN
      END IF
!
!  Load appropriate data block into output array.
!
      DO i=mstr,mend
        awrk(i)=a(i)
      END DO
!
!  Deallocate receive buffer.
!
      IF (allocated(arecv).and.(myrank.eq.mymaster)) THEN
        deallocate (arecv)
      END IF
 
# ifdef PROFILE
!
!-----------------------------------------------------------------------
!  Turn off time clocks.
!-----------------------------------------------------------------------
!
      CALL wclock_off (ng, model, 67, __line__, myfile)
# endif
!
      RETURN

References mod_param::bmemmax, mod_scalars::exit_flag, 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().

Referenced by ad_pack(), ad_pack_tile(), and tl_pack().

Here is the call graph for this function:

Here is the caller graph for this function: