#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: Jim Rosinski!!---------------------------------------------------------------------------!! Compile these routines only when SPMD is defined!#if (defined SPMD)!****************************************************************   subroutine mpibarrier (comm)   use precision   use mpishorthand   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!! End of all MPI communication!   use precision   use mpishorthand   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)!! Returns the size of the packed data!   use precision   use mpishorthand   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,    &                       position, comm)!! Pack the data and send it.!   use precision   use mpishorthand   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,  &                         datatype, comm)!! Un-packs the data from the packed receive buffer!   use precision   use mpishorthand   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,  &                           recvbuf, recvcount, recvtype, source,recvtag, &                           comm)!! Blocking send and receive.!   use precision   use mpishorthand   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)!! Does a non-blocking send.!   use precision   use mpishorthand   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 mpiirecv (buf, count, datatype, source, tag, comm, request)!! Does a non-blocking receive.!   use precision   use mpishorthand   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 mpiwaitall (count, array_of_requests, array_of_statuses)!! Waits for a collection of nonblocking operations to complete.!   use precision   use mpishorthand   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)!! Does a blocking send!   use precision   use mpishorthand   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')