mpp_transmit.inc

! -*-f90-*-
 
!***********************************************************************
!*                             Apache License 2.0
!*
!* This file is part of the GFDL Flexible Modeling System (FMS).
!*
!* Licensed under the Apache License, Version 2.0 (the "License");
!* you may not use this file except in compliance with the License.
!* You may obtain a copy of the License at
!*
!*     http://www.apache.org/licenses/LICENSE-2.0
!*
!* FMS is distributed in the hope that it will be useful, but WITHOUT
!* WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied;
!* without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
!* PARTICULAR PURPOSE. See the License for the specific language
!* governing permissions and limitations under the License.
!***********************************************************************
!> @file
!> @brief Routines for data transmission between PE's
 
!> @addtogroup mpp_mod
!> @{
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                             !
!                                  MPP_TRANSMIT                               !
!                                                                             !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
    subroutine mpp_transmit_scalar_( put_data, to_pe, get_data, from_pe, plen, glen, block, tag, &
                                    recv_request, send_request)
      integer, intent(in) :: to_pe, from_pe
      mpp_type_, intent(in)  :: put_data
      mpp_type_, intent(out) :: get_data
      integer, optional,  intent(in) :: plen, glen
      logical, intent(in),  optional :: block
      integer, intent(in),  optional :: tag
      integer, intent(out), optional :: recv_request, send_request
      integer                       :: put_len, get_len
      mpp_type_ :: put_data1d(1), get_data1d(1)
      pointer( ptrp, put_data1d )
      pointer( ptrg, get_data1d )
 
      get_data = mpp_type_init_value
 
      ptrp = loc(put_data)
      ptrg = loc(get_data)
      put_len=1; if(PRESENT(plen))put_len=plen
      get_len=1; if(PRESENT(glen))get_len=glen
      call mpp_transmit_ ( put_data1d, put_len, to_pe, get_data1d, get_len, from_pe, block, tag, &
                           recv_request=recv_request, send_request=send_request )
 
      return
    end subroutine mpp_transmit_scalar_
 
    subroutine mpp_transmit_2d_( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, &
                                recv_request, send_request )
      integer, intent(in) :: put_len, to_pe, get_len, from_pe
      mpp_type_, intent(in)  :: put_data(:,:)
      mpp_type_, intent(out) :: get_data(:,:)
      logical, intent(in), optional :: block
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: recv_request, send_request
      mpp_type_ :: put_data1d(put_len), get_data1d(get_len)
 
      pointer( ptrp, put_data1d )
      pointer( ptrg, get_data1d )
      get_data = mpp_type_init_value
 
      ptrp = loc(put_data)
      ptrg = loc(get_data)
      call mpp_transmit( put_data1d, put_len, to_pe, get_data1d, get_len, from_pe, block, tag, &
                         recv_request=recv_request, send_request=send_request )
 
      return
    end subroutine mpp_transmit_2d_
 
    subroutine mpp_transmit_3d_( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, &
                                recv_request, send_request )
      integer, intent(in) :: put_len, to_pe, get_len, from_pe
      mpp_type_, intent(in)  :: put_data(:,:,:)
      mpp_type_, intent(out) :: get_data(:,:,:)
      logical, intent(in), optional :: block
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: recv_request, send_request
      mpp_type_ :: put_data1d(put_len), get_data1d(get_len)
 
      pointer( ptrp, put_data1d )
      pointer( ptrg, get_data1d )
      get_data = mpp_type_init_value
 
      ptrp = loc(put_data)
      ptrg = loc(get_data)
      call mpp_transmit( put_data1d, put_len, to_pe, get_data1d, get_len, from_pe, block, tag, &
                         recv_request=recv_request, send_request=send_request )
 
      return
    end subroutine mpp_transmit_3d_
 
    subroutine mpp_transmit_4d_( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, &
                                recv_request, send_request )
      integer, intent(in) :: put_len, to_pe, get_len, from_pe
      mpp_type_, intent(in)  :: put_data(:,:,:,:)
      mpp_type_, intent(out) :: get_data(:,:,:,:)
      logical, intent(in), optional :: block
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: recv_request, send_request
      mpp_type_ :: put_data1d(put_len), get_data1d(get_len)
 
      pointer( ptrp, put_data1d )
      pointer( ptrg, get_data1d )
      get_data = mpp_type_init_value
 
      ptrp = loc(put_data)
      ptrg = loc(get_data)
      call mpp_transmit( put_data1d, put_len, to_pe, get_data1d, get_len, from_pe, block, tag, &
                         recv_request=recv_request, send_request=send_request )
 
      return
    end subroutine mpp_transmit_4d_
 
    subroutine mpp_transmit_5d_( put_data, put_len, to_pe, get_data, get_len, from_pe, block, tag, &
                                recv_request, send_request )
      integer, intent(in) :: put_len, to_pe, get_len, from_pe
      mpp_type_, intent(in)  :: put_data(:,:,:,:,:)
      mpp_type_, intent(out) :: get_data(:,:,:,:,:)
      logical, intent(in), optional :: block
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: recv_request, send_request
      mpp_type_ :: put_data1d(put_len), get_data1d(get_len)
 
      pointer( ptrp, put_data1d )
      pointer( ptrg, get_data1d )
      get_data = mpp_type_init_value
 
      ptrp = loc(put_data)
      ptrg = loc(get_data)
      call mpp_transmit( put_data1d, put_len, to_pe, get_data1d, get_len, from_pe, block, tag, &
                         recv_request=recv_request, send_request=send_request )
 
      return
    end subroutine mpp_transmit_5d_
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                             !
!                              MPP_SEND and RECV                              !
!                                                                             !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
    subroutine mpp_recv_( get_data, get_len, from_pe, block, tag, request )
!a mpp_transmit with null arguments on the put side
      integer, intent(in) :: get_len, from_pe
      mpp_type_, intent(out) :: get_data(*)
      logical, intent(in), optional :: block
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
 
      mpp_type_ :: dummy(1)
      call mpp_transmit( dummy, 1, null_pe, get_data, get_len, from_pe, block, tag, recv_request=request )
    end subroutine mpp_recv_
 
    subroutine mpp_send_( put_data, put_len, to_pe, tag, request )
!a mpp_transmit with null arguments on the get side
      integer, intent(in) :: put_len, to_pe
      mpp_type_, intent(in) :: put_data(*)
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
      mpp_type_ :: dummy(1)
      call mpp_transmit( put_data, put_len, to_pe, dummy, 1, null_pe, tag=tag, send_request=request )
    end subroutine mpp_send_
 
    subroutine mpp_recv_scalar_( get_data, from_pe, glen, block, tag, request )
!a mpp_transmit with null arguments on the put side
      integer, intent(in) :: from_pe
      mpp_type_, intent(out) :: get_data
      logical, intent(in), optional :: block
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
 
      integer, optional, intent(in) :: glen
      integer                       :: get_len
      mpp_type_ :: get_data1d(1)
      mpp_type_ :: dummy(1)
 
      pointer( ptr, get_data1d )
      get_data = mpp_type_init_value
 
      ptr = loc(get_data)
      get_len=1; if(PRESENT(glen))get_len=glen
      call mpp_transmit( dummy, 1, null_pe, get_data1d, get_len, from_pe, block, tag, recv_request=request )
 
    end subroutine mpp_recv_scalar_
 
    subroutine mpp_send_scalar_( put_data, to_pe, plen, tag, request)
!a mpp_transmit with null arguments on the get side
      integer, intent(in) :: to_pe
      mpp_type_, intent(in) :: put_data
      integer, optional, intent(in) :: plen
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
      integer                       :: put_len
      mpp_type_ :: put_data1d(1)
      mpp_type_ :: dummy(1)
 
      pointer( ptr, put_data1d )
      ptr = loc(put_data)
      put_len=1; if(PRESENT(plen))put_len=plen
      call mpp_transmit( put_data1d, put_len, to_pe, dummy, 1, null_pe, tag = tag, send_request=request )
 
    end subroutine mpp_send_scalar_
 
    subroutine mpp_recv_2d_( get_data, get_len, from_pe, block, tag, request )
!a mpp_transmit with null arguments on the put side
      integer, intent(in) :: get_len, from_pe
      mpp_type_, intent(out) :: get_data(:,:)
      logical, intent(in), optional :: block
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
 
      mpp_type_ :: dummy(1,1)
      call mpp_transmit( dummy, 1, null_pe, get_data, get_len, from_pe, block, tag, recv_request=request )
    end subroutine mpp_recv_2d_
 
    subroutine mpp_send_2d_( put_data, put_len, to_pe, tag, request )
!a mpp_transmit with null arguments on the get side
      integer, intent(in) :: put_len, to_pe
      mpp_type_, intent(in) :: put_data(:,:)
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
      mpp_type_ :: dummy(1,1)
      call mpp_transmit( put_data, put_len, to_pe, dummy, 1, null_pe, tag = tag, send_request=request )
    end subroutine mpp_send_2d_
 
    subroutine mpp_recv_3d_( get_data, get_len, from_pe, block, tag, request )
!a mpp_transmit with null arguments on the put side
      integer, intent(in) :: get_len, from_pe
      mpp_type_, intent(out) :: get_data(:,:,:)
      logical, intent(in), optional :: block
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
 
      mpp_type_ :: dummy(1,1,1)
      call mpp_transmit( dummy, 1, null_pe, get_data, get_len, from_pe, block, tag, recv_request=request )
    end subroutine mpp_recv_3d_
 
    subroutine mpp_send_3d_( put_data, put_len, to_pe, tag, request )
!a mpp_transmit with null arguments on the get side
      integer, intent(in) :: put_len, to_pe
      mpp_type_, intent(in) :: put_data(:,:,:)
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
      mpp_type_ :: dummy(1,1,1)
      call mpp_transmit( put_data, put_len, to_pe, dummy, 1, null_pe, tag = tag, send_request=request )
    end subroutine mpp_send_3d_
 
    subroutine mpp_recv_4d_( get_data, get_len, from_pe, block, tag, request )
!a mpp_transmit with null arguments on the put side
      integer, intent(in) :: get_len, from_pe
      mpp_type_, intent(out) :: get_data(:,:,:,:)
      logical, intent(in), optional :: block
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
 
      mpp_type_ :: dummy(1,1,1,1)
      call mpp_transmit( dummy, 1, null_pe, get_data, get_len, from_pe, block, tag, recv_request=request )
    end subroutine mpp_recv_4d_
 
    subroutine mpp_send_4d_( put_data, put_len, to_pe, tag, request )
!a mpp_transmit with null arguments on the get side
      integer, intent(in) :: put_len, to_pe
      mpp_type_, intent(in) :: put_data(:,:,:,:)
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
      mpp_type_ :: dummy(1,1,1,1)
      call mpp_transmit( put_data, put_len, to_pe, dummy, 1, null_pe, tag = tag, send_request=request )
    end subroutine mpp_send_4d_
 
    subroutine mpp_recv_5d_( get_data, get_len, from_pe, block, tag, request)
!a mpp_transmit with null arguments on the put side
      integer, intent(in) :: get_len, from_pe
      mpp_type_, intent(out) :: get_data(:,:,:,:,:)
      logical, intent(in), optional :: block
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
 
      mpp_type_ :: dummy(1,1,1,1,1)
      call mpp_transmit( dummy, 1, null_pe, get_data, get_len, from_pe, block, tag, recv_request=request )
    end subroutine mpp_recv_5d_
 
    subroutine mpp_send_5d_( put_data, put_len, to_pe, tag, request )
!a mpp_transmit with null arguments on the get side
      integer, intent(in) :: put_len, to_pe
      mpp_type_, intent(in) :: put_data(:,:,:,:,:)
      integer, intent(in), optional :: tag
      integer, intent(out), optional :: request
      mpp_type_ :: dummy(1,1,1,1,1)
      call mpp_transmit( put_data, put_len, to_pe, dummy, 1, null_pe, tag = tag, send_request=request )
    end subroutine mpp_send_5d_
 
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!                                                                             !
!                                MPP_BROADCAST                                !
!                                                                             !
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
    subroutine mpp_broadcast_scalar_( broadcast_data, from_pe, pelist )
      mpp_type_, intent(inout) :: broadcast_data
      integer, intent(in) :: from_pe
      integer, intent(in), optional :: pelist(:)
      mpp_type_ :: data1d(1)
 
      pointer( ptr, data1d )
 
      ptr = loc(broadcast_data)
      call mpp_broadcast_( data1d, 1, from_pe, pelist )
 
      return
    end subroutine mpp_broadcast_scalar_
 
    subroutine mpp_broadcast_2d_( broadcast_data, length, from_pe, pelist )
!this call was originally bundled in with mpp_transmit, but that doesn't allow
!broadcast to a subset of PEs. This version will, and mpp_transmit will remain
!backward compatible.
      mpp_type_, intent(inout) :: broadcast_data(:,:)
      integer, intent(in) :: length, from_pe
      integer, intent(in), optional :: pelist(:)
      mpp_type_ :: data1d(length)
 
      pointer( ptr, data1d )
      ptr = loc(broadcast_data)
      call mpp_broadcast( data1d, length, from_pe, pelist )
 
      return
    end subroutine mpp_broadcast_2d_
 
    subroutine mpp_broadcast_3d_( broadcast_data, length, from_pe, pelist )
!this call was originally bundled in with mpp_transmit, but that doesn't allow
!broadcast to a subset of PEs. This version will, and mpp_transmit will remain
!backward compatible.
      mpp_type_, intent(inout) :: broadcast_data(:,:,:)
      integer, intent(in) :: length, from_pe
      integer, intent(in), optional :: pelist(:)
      mpp_type_ :: data1d(length)
 
      pointer( ptr, data1d )
      ptr = loc(broadcast_data)
      call mpp_broadcast( data1d, length, from_pe, pelist )
 
      return
   end subroutine mpp_broadcast_3d_
 
    subroutine mpp_broadcast_4d_( broadcast_data, length, from_pe, pelist )
!this call was originally bundled in with mpp_transmit, but that doesn't allow
!broadcast to a subset of PEs. This version will, and mpp_transmit will remain
!backward compatible.
      mpp_type_, intent(inout) :: broadcast_data(:,:,:,:)
      integer, intent(in) :: length, from_pe
      integer, intent(in), optional :: pelist(:)
      mpp_type_ :: data1d(length)
 
      pointer( ptr, data1d )
      ptr = loc(broadcast_data)
      call mpp_broadcast( data1d, length, from_pe, pelist )
 
      return
    end subroutine mpp_broadcast_4d_
 
    subroutine mpp_broadcast_5d_( broadcast_data, length, from_pe, pelist )
!this call was originally bundled in with mpp_transmit, but that doesn't allow
!broadcast to a subset of PEs. This version will, and mpp_transmit will remain
!backward compatible.
      mpp_type_, intent(inout) :: broadcast_data(:,:,:,:,:)
      integer, intent(in) :: length, from_pe
      integer, intent(in), optional :: pelist(:)
      mpp_type_ :: data1d(length)
 
      pointer( ptr, data1d )
      ptr = loc(broadcast_data)
      call mpp_broadcast( data1d, length, from_pe, pelist )
 
      return
    end subroutine mpp_broadcast_5d_
!> @}