wrap_mpi.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

 
   return
   end subroutine mpisend
 
!****************************************************************
 
   subroutine mpirecv (buf, count, datatype, source, tag, comm)
!
! Does a 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 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, &
                         recvtype, root, comm)
!
! Collects different messages from each thread on masterproc
!
   use precision
   use mpishorthand
   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, &
                          displs, recvtype, root, comm)
!
! Collects different messages from each thread on masterproc
!
   use precision
   use mpishorthand
   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)
!
! Sums sendbuf across all processors on communicator, returning 
! result to root.
!
   use precision
   use mpishorthand
   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, &
                          recvtype, root, comm)
!
! Sends different messages from masterproc to each thread
! 
   use precision
   use mpishorthand
   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, &
                           recvcnt, recvtype, root, comm)
!
! Sends different messages from masterproc to each thread
! 
   use precision
   use mpishorthand
   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 )
!
! Broadcasts a message from masterproc to all threads
!
   use precision
   use mpishorthand
   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, &
                            recvbuf, recvcnts, rdispls, recvtype, &
                            comm)
!
! All-to-all scatter/gather
! 
   use precision
   use mpishorthand
   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 mpiallgatherint (sendbuf, scount, recvbuf, rcount, comm)
!
! Collects integer data from each task and broadcasts resulting
! vector to all tasks
!
   use precision
   use mpishorthand
   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
   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).
!
   write(6,*) '(WRAP_MPI): This should not be called at all'
   call endrun
   end subroutine wrap_mpi
#endif