#include <misc.h>
!---------------------------------------------------------------------------
!
! Purpose:
!
! 	Wrapper routines for the MPI (Message Passing) library for the
!	distributed memory (SPMD) version of the code. Also data with
!	"shorthand" names for the MPI data types.
!
! Author: Many
!
!---------------------------------------------------------------------------
!
! Compile these routines only when SPMD is defined
!
#if (defined SPMD)

!****************************************************************


   subroutine mpibarrier (comm) 12,3

   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun

   implicit none
!
! MPI barrier, have threads wait until all threads have reached this point
!
   integer, intent(in):: comm
 
   integer ier   !MP error code
 
   call mpi_barrier (comm, ier)
   if (ier.ne.mpi_success) then
      write(6,*)'mpi_barrier failed ier=',ier
      call endrun
   end if
 
   return
   end subroutine mpibarrier
 
!****************************************************************
 

   subroutine mpifinalize 1,3
!
! End of all MPI communication
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   integer ier   !MP error code
 
   call mpi_finalize (ier)
   if (ier.ne.mpi_success) then
      write(6,*)'mpi_finalize failed ier=',ier
      call endrun
   end if
 
   return
   end subroutine mpifinalize
 
!****************************************************************
 

   subroutine mpipack_size (incount, datatype, comm, size),3
!
! Returns the size of the packed data
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   integer, intent(in):: incount
   integer, intent(in):: datatype
   integer, intent(in):: comm
   integer, intent(out):: size
 
   integer ier   !MP error code
 
   call mpi_pack_size (incount, datatype, comm, size, ier)
   if (ier.ne.mpi_success) then
      write(6,*)'mpi_pack_size failed ier=',ier
      call endrun
   end if
 
   return
   end subroutine mpipack_size
 
!****************************************************************
 

   subroutine mpipack (inbuf, incount, datatype, outbuf, outsize,    &,3
                       position, comm)
!
! Pack the data and send it.
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real(r8), intent(in):: inbuf(*)
   real(r8), intent(out):: outbuf(*)
   integer, intent(in):: incount
   integer, intent(in):: datatype
   integer, intent(out):: outsize
   integer, intent(inout):: position
   integer, intent(in):: comm
 
   integer ier   !MP error code
 
   call mpi_pack (inbuf, incount, datatype, outbuf, outsize,         &
     &            position, comm, ier)
   if (ier.ne.mpi_success) then
      write(6,*)'mpi_pack failed ier=',ier
      call endrun
   end if
 
   return
   end subroutine mpipack
 
!****************************************************************
 

   subroutine mpiunpack (inbuf, insize, position, outbuf, outcount,  &,3
                         datatype, comm)
!
! Un-packs the data from the packed receive buffer
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real(r8), intent(in):: inbuf(*)
   real(r8), intent(out):: outbuf(*)
   integer, intent(in):: insize
   integer, intent(inout):: position
   integer, intent(in):: outcount
   integer, intent(in):: datatype
   integer, intent(in):: comm
 
   integer ier   !MP error code
 
   call mpi_unpack (inbuf, insize, position, outbuf, outcount,       &
     &              datatype, comm, ier)
   if (ier.ne.mpi_success) then
      write(6,*)'mpi_unpack failed ier=',ier
      call endrun
   end if
 
   return
   end subroutine mpiunpack
 
!****************************************************************
 

   subroutine mpisendrecv (sendbuf, sendcount, sendtype, dest, sendtag,  & 2,3
                           recvbuf, recvcount, recvtype, source,recvtag, &
                           comm)
!
! Blocking send and receive.
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real(r8), intent(in):: sendbuf(*)
   real(r8), intent(out):: recvbuf(*)
   integer, intent(in):: sendcount
   integer, intent(in):: sendtype
   integer, intent(in):: dest
   integer, intent(in):: sendtag
   integer, intent(in):: recvcount
   integer, intent(in):: recvtype
   integer, intent(in):: source
   integer, intent(in):: recvtag
   integer, intent(in):: comm
 
   integer :: status(MPI_STATUS_SIZE)
   integer ier   !MP error code
 
   call t_startf ('mpi_sendrecv')
   call mpi_sendrecv (sendbuf, sendcount, sendtype, dest, sendtag,   &
     &                recvbuf, recvcount, recvtype, source, recvtag, &
     &                comm, status, ier)
   if (ier.ne.mpi_success) then
      write(6,*)'mpi_sendrecv failed ier=',ier
      call endrun
   end if
!
! ASSUME nrecv = nsend for stats gathering purposes.  This is not actually
! correct, but its the best we can do since recvcount is a Max number
!
   nsend = nsend + 1
   nrecv = nrecv + 1
   nwsend = nwsend + sendcount
   nwrecv = nwrecv + sendcount

   call t_stopf ('mpi_sendrecv')
 
   return
   end subroutine mpisendrecv
 
!****************************************************************
 

   subroutine mpiisend (buf, count, datatype, dest, tag, comm, request) 9,3
!
! Does a non-blocking send.
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8), intent(in):: buf(*)
   integer, intent(in):: count
   integer, intent(in):: datatype
   integer, intent(in):: dest
   integer, intent(in):: tag
   integer, intent(in):: comm
   integer, intent(out):: request
 
   integer ier   !MP error code
 
   call t_startf ('mpi_isend')
   call mpi_isend (buf, count, datatype, dest, tag, comm, request, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_isend failed ier=',ier
      call endrun
   end if
   nsend = nsend + 1
   nwsend = nwsend + count
   call t_stopf ('mpi_isend')
 
   return
   end subroutine mpiisend
 
!****************************************************************
 

   subroutine mpiirsend (buf, count, datatype, dest, tag, comm, request) 4,3
!
! Does a non-blocking ready send.
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun

   implicit none
 
   real (r8), intent(in):: buf(*)
   integer, intent(in):: count
   integer, intent(in):: datatype
   integer, intent(in):: dest
   integer, intent(in):: tag
   integer, intent(in):: comm
   integer, intent(out):: request
 
   integer ier   !MP error code
 
   call t_startf ('mpi_irsend')
   call mpi_irsend (buf, count, datatype, dest, tag, comm, request, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_irsend failed ier=',ier
      call endrun
   end if
   nsend = nsend + 1
   nwsend = nwsend + count
   call t_stopf ('mpi_irsend')
 
   return
   end subroutine mpiirsend
 
!****************************************************************
 

   subroutine mpiissend (buf, count, datatype, dest, tag, comm, request) 7,3
!
! Does a non-blocking synchronous send.
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun

   implicit none
 
   real (r8), intent(in):: buf(*)
   integer, intent(in):: count
   integer, intent(in):: datatype
   integer, intent(in):: dest
   integer, intent(in):: tag
   integer, intent(in):: comm
   integer, intent(out):: request
 
   integer ier   !MP error code
 
   call t_startf ('mpi_issend')
   call mpi_issend (buf, count, datatype, dest, tag, comm, request, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_issend failed ier=',ier
      call endrun
   end if
   nsend = nsend + 1
   nwsend = nwsend + count
   call t_stopf ('mpi_issend')
 
   return
   end subroutine mpiissend
 
!****************************************************************
 

   subroutine mpiirecv (buf, count, datatype, source, tag, comm, request) 14,3
!
! Does a non-blocking receive.
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8), intent(out):: buf(*)
   integer, intent(in):: count
   integer, intent(in):: datatype
   integer, intent(in):: source
   integer, intent(in):: tag
   integer, intent(in):: comm
   integer, intent(out):: request
 
   integer ier   !MP error code
 
   call t_startf ('mpi_irecv')
   call mpi_irecv (buf, count, datatype, source, tag, comm, request, ier )
   if (ier/=mpi_success) then
      write(6,*)'mpi_irecv failed ier=',ier
      call endrun
   end if
   nrecv = nrecv + 1
   nwrecv = nwrecv + count
   call t_stopf ('mpi_irecv')
 
   return
   end subroutine mpiirecv
 
!****************************************************************
 

   subroutine mpiwait (request, status) 31,3
!
! Waits for a nonblocking operation to complete.
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun

   implicit none
 
   integer, intent(inout):: request
   integer, intent(out):: status
 
   integer ier   !MP error code
 
   call t_startf ('mpi_wait')
   call mpi_wait (request, status, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_wait failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_wait')
 
   return
   end subroutine mpiwait
 
!****************************************************************
 

   subroutine mpiwaitall (count, array_of_requests, array_of_statuses) 13,3
!
! Waits for a collection of nonblocking operations to complete.
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   integer, intent(in):: count
   integer, intent(inout):: array_of_requests(*)
   integer, intent(out):: array_of_statuses(*)
 
   integer ier   !MP error code
 
   call t_startf ('mpi_waitall')
   call mpi_waitall (count, array_of_requests, array_of_statuses, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_waitall failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_waitall')
 
   return
   end subroutine mpiwaitall
 
!****************************************************************
 

   subroutine mpisend (buf, count, datatype, dest, tag, comm) 14,3
!
! Does a blocking send
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8), intent(in):: buf(*)
   integer, intent(in):: count
   integer, intent(in):: datatype
   integer, intent(in):: dest
   integer, intent(in):: tag
   integer, intent(in):: comm
 
   integer ier   !MP error code
 
   call t_startf ('mpi_send')
   call mpi_send (buf, count, datatype, dest, tag, comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_send failed ier=',ier
      call endrun
   end if
   nsend = nsend + 1
   nwsend = nwsend + count
   call t_stopf ('mpi_send')
 
   return
   end subroutine mpisend
 
!****************************************************************
 

   subroutine mpirsend (buf, count, datatype, dest, tag, comm) 4,3
!
! Does a blocking ready send
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun

   implicit none
 
   real (r8), intent(in):: buf(*)
   integer, intent(in):: count
   integer, intent(in):: datatype
   integer, intent(in):: dest
   integer, intent(in):: tag
   integer, intent(in):: comm
 
   integer ier   !MP error code
 
   call t_startf ('mpi_rsend')
   call mpi_rsend (buf, count, datatype, dest, tag, comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_rsend failed ier=',ier
      call endrun
   end if
   nsend = nsend + 1
   nwsend = nwsend + count
   call t_stopf ('mpi_rsend')
 
   return
   end subroutine mpirsend
 
!****************************************************************
 

   subroutine mpissend (buf, count, datatype, dest, tag, comm) 6,3
!
! Does a blocking synchronous send
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun

   implicit none
 
   real (r8), intent(in):: buf(*)
   integer, intent(in):: count
   integer, intent(in):: datatype
   integer, intent(in):: dest
   integer, intent(in):: tag
   integer, intent(in):: comm
 
   integer ier   !MP error code
 
   call t_startf ('mpi_ssend')
   call mpi_ssend (buf, count, datatype, dest, tag, comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_ssend failed ier=',ier
      call endrun
   end if
   nsend = nsend + 1
   nwsend = nwsend + count
   call t_stopf ('mpi_ssend')
 
   return
   end subroutine mpissend
 
!****************************************************************
 

   subroutine mpirecv (buf, count, datatype, source, tag, comm) 26,3
!
! Does a blocking receive
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8), intent(out):: buf(*)
   integer, intent(in):: count
   integer, intent(in):: datatype
   integer, intent(in):: source
   integer, intent(in):: tag
   integer, intent(in):: comm
 
   integer status (MPI_STATUS_SIZE) ! Status of message
   integer ier   !MP error code
 
   call t_startf ('mpi_recv')
   call mpi_recv (buf, count, datatype, source, tag, comm, status, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_recv failed ier=',ier
      call endrun
   end if
   nrecv = nrecv + 1
   nwrecv = nwrecv + count
   call t_stopf ('mpi_recv')
 
   return
   end subroutine mpirecv
 
!****************************************************************
 

   subroutine mpigather (sendbuf, sendcnt, sendtype, recvbuf, recvcnt, &,3
                         recvtype, root, comm)
!
! Collects different messages from each thread on masterproc
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8), intent(in):: sendbuf(*)
   real (r8), intent(out):: recvbuf(*)
   integer, intent(in):: sendcnt
   integer, intent(in):: sendtype
   integer, intent(in):: recvcnt
   integer, intent(in):: recvtype
   integer, intent(in):: root
   integer, intent(in):: comm
 
   integer ier   !MP error code
 
   call t_startf ('mpi_gather')
   call mpi_gather (sendbuf, sendcnt, sendtype,                      &
     &              recvbuf, recvcnt, recvtype, root, comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_gather failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_gather')
 
   return
   end subroutine mpigather
 
!****************************************************************
 

   subroutine mpigatherv (sendbuf, sendcnt, sendtype, recvbuf, recvcnts, & 10,3
                          displs, recvtype, root, comm)
!
! Collects different messages from each thread on masterproc
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8), intent(in)  :: sendbuf(*)
   real (r8), intent(out) :: recvbuf(*)
   integer, intent(in) :: displs(*)
   integer, intent(in) :: sendcnt
   integer, intent(in) :: sendtype
   integer, intent(in) :: recvcnts(*)
   integer, intent(in) :: recvtype
   integer, intent(in) :: root
   integer, intent(in) :: comm
 
   integer ier   ! MPI error code
 
   call t_startf ('mpi_gather')
   call mpi_gatherv (sendbuf, sendcnt, sendtype, recvbuf, recvcnts, displs, recvtype, &
                     root, comm, ier)
   if (ier /= mpi_success) then
      write(6,*)'mpi_gather failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_gather')
 
   return
   end subroutine mpigatherv
 
!****************************************************************
 

   subroutine mpisum (sendbuf, recvbuf, cnt, datatype, root, comm) 4,3
!
! Sums sendbuf across all processors on communicator, returning 
! result to root.
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8), intent(in):: sendbuf(*)
   real (r8), intent(out):: recvbuf(*)
   integer, intent(in):: cnt
   integer, intent(in):: datatype
   integer, intent(in):: root
   integer, intent(in):: comm
 
   integer ier   !MP error code
 
   call t_startf ('mpi_reduce')
   call mpi_reduce (sendbuf, recvbuf, cnt, datatype, mpi_sum, &
                    root, comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_reduce failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_reduce')
 
   return
   end subroutine mpisum
 
!****************************************************************
 

   subroutine mpiscatter (sendbuf, sendcnt, sendtype, recvbuf, recvcnt, &,3
                          recvtype, root, comm)
!
! Sends different messages from masterproc to each thread
! 
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8),intent(in):: sendbuf(*)
   real (r8), intent(out):: recvbuf(*)
   integer,intent(in):: sendcnt
   integer,intent(in):: sendtype
   integer,intent(in):: recvcnt
   integer,intent(in):: recvtype
   integer,intent(in):: root
   integer,intent(in):: comm
 
   integer ier   !MP error code
 
   call t_startf ('mpi_scatter')
   call mpi_scatter (sendbuf, sendcnt, sendtype, recvbuf, recvcnt, &
   &                 recvtype, root, comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_scatter failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_scatter')
 
   return
   end subroutine mpiscatter
 
!****************************************************************
 

   subroutine mpiscatterv (sendbuf, sendcnts, displs, sendtype, recvbuf, & 6,3
                           recvcnt, recvtype, root, comm)
!
! Sends different messages from masterproc to each thread
! 
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8), intent(in)  :: sendbuf(*)
   real (r8), intent(out) :: recvbuf(*)
   integer, intent(in) :: displs(*)
   integer, intent(in) :: sendcnts(*)
   integer, intent(in) :: sendtype
   integer, intent(in) :: recvcnt
   integer, intent(in) :: recvtype
   integer, intent(in) :: root
   integer, intent(in) :: comm
 
   integer ier   !MP error code
 
   call t_startf ('mpi_scatter')
   call mpi_scatterv (sendbuf, sendcnts, displs, sendtype, recvbuf, recvcnt, &
                      recvtype, root, comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_scatter failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_scatter')
 
   return
   end subroutine mpiscatterv
 
!****************************************************************
 

   subroutine mpibcast (buffer, count, datatype, root, comm ) 272,3
!
! Broadcasts a message from masterproc to all threads
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8), intent(inout):: buffer(*)
   integer, intent(in):: count
   integer, intent(in):: datatype
   integer, intent(in):: root
   integer, intent(in):: comm
 
   integer ier   !MP error code
 
   call t_startf ('mpi_bcast')
   call mpi_bcast (buffer, count, datatype, root, comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_bcast failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_bcast')
 
   return
   end subroutine mpibcast
!****************************************************************
 

   subroutine mpialltoallv (sendbuf, sendcnts, sdispls, sendtype, & 2,3
                            recvbuf, recvcnts, rdispls, recvtype, &
                            comm)
!
! All-to-all scatter/gather
! 
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   real (r8), intent(in)  :: sendbuf(*)
   real (r8), intent(out) :: recvbuf(*)
   integer, intent(in) :: sdispls(*)
   integer, intent(in) :: sendcnts(*)
   integer, intent(in) :: sendtype
   integer, intent(in) :: recvcnts(*)
   integer, intent(in) :: rdispls(*)
   integer, intent(in) :: recvtype
   integer, intent(in) :: comm
 
   integer ier   !MP error code
 
   call t_startf ('mpi_alltoallv')
   call mpi_alltoallv (sendbuf, sendcnts, sdispls, sendtype, &
                       recvbuf, recvcnts, rdispls, recvtype, &
                       comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_alltoallv failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_alltoallv')
 
   return
   end subroutine mpialltoallv
!****************************************************************
 

   subroutine mpiallgatherv (sendbuf, sendcnt, sendtype, &,3
                             recvbuf, recvcnts, rdispls, recvtype, &
                             comm)
!
! Collect data from each task and broadcast resulting
! vector to all tasks
! 
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun

   implicit none
 
   real (r8), intent(in)  :: sendbuf(*)
   real (r8), intent(out) :: recvbuf(*)
   integer, intent(in) :: sendcnt
   integer, intent(in) :: sendtype
   integer, intent(in) :: recvcnts(*)
   integer, intent(in) :: rdispls(*)
   integer, intent(in) :: recvtype
   integer, intent(in) :: comm
 
   integer ier   !MP error code
 
   call t_startf ('mpi_allgatherv')
   call mpi_allgatherv (sendbuf, sendcnt, sendtype, &
                        recvbuf, recvcnts, rdispls, recvtype, &
                        comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_allgatherv failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_allgatherv')
 
   return
   end subroutine mpiallgatherv
!****************************************************************
 

   subroutine mpiallgatherint (sendbuf, scount, recvbuf, rcount, comm) 1,3
!
! Collects integer data from each task and broadcasts resulting
! vector to all tasks
!
   use shr_kind_mod, only: r8 => shr_kind_r8
   use mpishorthand
   use abortutils, only: endrun
   implicit none
 
   integer, intent(in)  :: sendbuf(*)
   integer, intent(out) :: recvbuf(*)
   integer, intent(in) :: scount
   integer, intent(in) :: rcount
   integer, intent(in) :: comm
 
   integer ier   !MP error code

   call t_startf ('mpi_allgather')
   call mpi_allgather (sendbuf, scount, mpiint, recvbuf, rcount, &
                       mpiint, comm, ier)
   if (ier/=mpi_success) then
      write(6,*)'mpi_allgather failed ier=',ier
      call endrun
   end if
   call t_stopf ('mpi_allgather')
 
   return
   end subroutine mpiallgatherint
!
! If SPMD is not turned on
!
#else

   subroutine wrap_mpi,1
   use abortutils, only: endrun
   implicit none
!
! A unused stub routine to make the compiler happy when SPMD is
! turned off (which means you don't need anything in this file).
!
   call endrun ('(WRAP_MPI): This should not be called at all')
   end subroutine wrap_mpi
#endif