    module mp
!  MP - Eric's routines for interfacing with MPI.  This version implements
!  a very simple message-passing scheme, namely blocking sends and receives
!  for an MPI_COMM_WORLD group of communicating processes.
!  Most of the routines in this module form a generic interface for
!  "send" and "receive".  That is, we can say
!    call send(value=something,dest=somewhere)
!  where value is any integer or real array and dest is an integer specifying
!  the process to which the value is to be sent.  Similarly, we can say
!    call receive(value=something,src=source,sender=p)
!  where src is an integer specifying the process that is supposed to
!  receive the value.  Sender is an optional argument that is set to the
!  process sending the data; normally, p = source, but source can also
!  be MPI_ANY_SOURCE, in which case one might want to know the identity
!  of the sender.
!  We also implement convenience functions myid() and nproc() to obtain
!  our MPI rank (identity) and the number of processes in the group,
!  respectively.  Subroutines startup and shutdown initialize and terminate
!  MPI, respectively.
!
!  Required packages:
!
    use mpi
    use ferror
    implicit none
!
    integer,parameter::ROOT=0
!
    integer,parameter,private::I_TAG=1
    integer,parameter,private::IA_TAG=11
    integer,parameter,private::R4=kind(1.0)
    integer,parameter,private::R8=kind(1.0d0)
    integer,parameter,private::R4_TAG=4
    integer,parameter,private::R8_TAG=8
    integer,parameter,private::R4A_TAG=14
    integer,parameter,private::R8A_TAG=18
    integer,save,private::me=ROOT
    integer,save,private::npes=1
!
    interface send
       module procedure send_i,send_ia,send_r4,send_r8,send_r4a,send_r8a
    end interface send
!
    interface receive
       module procedure recv_i,recv_ia,recv_r4,recv_r8,recv_r4a,recv_r8a
    end interface receive
    contains
!-----------------------------------------------------------------------
    pure integer function myid()
!  MYID - return the calling process's MPI rank.  Returns 0 if MPI is
!  not initialized by STARTUP.
!
    myid=me
    return
    end function myid
!-----------------------------------------------------------------------
    pure integer function nproc()
!  NPROC - return the number of processes in the group.  Returns 1 if MPI is
!  not initialized by STARTUP.
!
    nproc=npes
    return
    end function nproc
!-----------------------------------------------------------------------
    subroutine send_i(value,dest)
!  SEND_I - send a scalar default integer to DEST.
!
    integer,intent(in)::value,dest
!
    integer::buf(1),ierr
!
    buf(1)=value
    call mpi_send(buf,1,MPI_INTEGER,dest,I_TAG,MPI_COMM_WORLD,ierr)
    return
    end subroutine send_i
!-----------------------------------------------------------------------
    subroutine send_ia(value,dest)
!  SEND_IA - send a rank-1 default integer array to DEST.
!
    integer,intent(in)::value(:),dest
!
    integer::ierr,buf(size(value))
!
    buf=value  ! ensure contiguity
    call mpi_send(buf,size(buf),MPI_INTEGER,dest,IA_TAG,MPI_COMM_WORLD,ierr)
    return
    end subroutine send_ia
!-----------------------------------------------------------------------
    subroutine send_r4(value,dest)
!  SEND_R4 - send a scalar default real to DEST.
!
    real(R4),intent(in)::value
    integer,intent(in)::dest
!
    real(R4)::buf(1)
    integer::ierr
!
    buf(1)=value
    call mpi_send(buf,1,MPI_REAL4,dest,R4_TAG,MPI_COMM_WORLD,ierr)
    return
    end subroutine send_r4
!-----------------------------------------------------------------------
    subroutine send_r8(value,dest)
!  SEND_R8 - send a double precision real to DEST.
!
    real(R8),intent(in)::value
    integer,intent(in)::dest
!
    real(R8)::buf(1)
    integer::ierr
!
    buf(1)=value
    call mpi_send(buf,1,MPI_REAL8,dest,R8_TAG,MPI_COMM_WORLD,ierr)
    return
    end subroutine send_r8
!-----------------------------------------------------------------------
    subroutine send_r4a(value,dest)
!  SEND_R4A - send a rank-1 default real array to DEST.
!
    real(R4),intent(in)::value(:)
    integer,intent(in)::dest
!
    real(R4)::buf(size(value))
    integer::ierr
!
    buf=value  ! ensure contiguity
    call mpi_send(buf,1,MPI_REAL4,dest,R4A_TAG,MPI_COMM_WORLD,ierr)
    return
    end subroutine send_r4a
!-----------------------------------------------------------------------
    subroutine send_r8a(value,dest)
!  SEND_R8A - send a rank-1 double-precision array to DEST.
!
    real(R8),intent(in)::value(:)
    integer,intent(in)::dest
!
    real(R8)::buf(size(value))
    integer::ierr
!
    buf=value  ! ensure contiguity
    call mpi_send(buf,1,MPI_REAL8,dest,R8A_TAG,MPI_COMM_WORLD,ierr)
    return
    end subroutine send_r8a
!-----------------------------------------------------------------------
    subroutine recv_i(value,src,sender)
!  RECV_I - receive a scalar default integer value from SRC.  SRC may be
!  MPI_ANY_SOURCE, in which case the optional argument SENDER should be
!  present; the latter is set to the id of the actual sender.  Otherwise,
!  if SRC is the id of another process, then SENDER is set to SRC on return.
!
    integer,intent(out)::value
    integer,intent(in)::src
    integer,intent(out),optional::sender
!
    integer::ierr,buf(1),status(MPI_STATUS_SIZE)
!
    call mpi_recv(buf,1,MPI_INTEGER,src,I_TAG,MPI_COMM_WORLD,status,ierr)
    if(present(sender)) sender=status(MPI_SOURCE)
    value=buf(1)
    return
    end subroutine recv_i
!-----------------------------------------------------------------------
    subroutine recv_ia(value,src,sender)
!  RECV_IA - receive a default integer array from SRC.  SRC may be
!  MPI_ANY_SOURCE, in which case the optional argument SENDER should be
!  present; the latter is set to the id of the actual sender.  Otherwise,
!  if SRC is the id of another process, then SENDER is set to SRC on return.
!
    integer,intent(out)::value(:)
    integer,intent(in)::src
    integer,intent(out),optional::sender
!
    integer::ierr,count,buf(size(value)),status(MPI_STATUS_SIZE)
    character(80)::msg
!
    call mpi_recv(buf,size(buf),MPI_INTEGER,src,IA_TAG,MPI_COMM_WORLD, &
       status,ierr)
    if(present(sender)) sender=status(MPI_SOURCE)
    call mpi_get_count(status,MPI_INTEGER,count,ierr)
    if(count.ne.size(buf)) then
       write(msg,100) 'recv_ia',size(buf),count
       call fabort(msg)
    endif
    value=buf  ! in case value isn't contiguous
100 format(a,': expected: ',i0,' got: ',i0,' values')
    return
    end subroutine recv_ia
!-----------------------------------------------------------------------
    subroutine recv_r4(value,src,sender)
!  RECV_R4 - receive a scalar default real value from SRC.  SRC may be
!  MPI_ANY_SOURCE, in which case the optional argument SENDER should be
!  present; the latter is set to the id of the actual sender.  Otherwise,
!  if SRC is the id of another process, then SENDER is set to SRC on return.
!
    real(R4),intent(out)::value
    integer,intent(in)::src
    integer,intent(out),optional::sender
!
    real(R4)::buf(1)
    integer::ierr,status(MPI_STATUS_SIZE)
!
    call mpi_recv(buf,1,MPI_REAL4,src,R4_TAG,MPI_COMM_WORLD,status,ierr)
    value=buf(1)
    if(present(sender)) sender=status(MPI_SOURCE)
    return
    end subroutine recv_r4
!-----------------------------------------------------------------------
    subroutine recv_r8(value,src,sender)
!  RECV_R8 - receive a scalar double precision real value from SRC.  SRC may be
!  MPI_ANY_SOURCE, in which case the optional argument SENDER should be
!  present; the latter is set to the id of the actual sender.  Otherwise,
!  if SRC is the id of another process, then SENDER is set to SRC on return.
!
    real(R8),intent(out)::value
    integer,intent(in)::src
    integer,intent(out),optional::sender
!
    real(R8)::buf(1)
    integer::ierr,status(MPI_STATUS_SIZE)
!
    call mpi_recv(buf,1,MPI_REAL8,src,R8_TAG,MPI_COMM_WORLD,status,ierr)
    value=buf(1)
    if(present(sender)) sender=status(MPI_SOURCE)
    return
    end subroutine recv_r8
!-----------------------------------------------------------------------
    subroutine recv_r4a(value,src,sender)
!  RECV_R4A - receive a rank-1 default real array from SRC.  SRC may be
!  MPI_ANY_SOURCE, in which case the optional argument SENDER should be
!  present; the latter is set to the id of the actual sender.  Otherwise,
!  if SRC is the id of another process, then SENDER is set to SRC on return.
!
    real(R4),intent(out)::value(:)
    integer,intent(in)::src
    integer,intent(out),optional::sender
!
    real(R4)::buf(size(value))
    integer::count,ierr,status(MPI_STATUS_SIZE)
    character(80)::msg
!
    call mpi_recv(buf,size(buf),MPI_REAL4,src,R4A_TAG,MPI_COMM_WORLD,status, &
       ierr)
    if(present(sender)) sender=status(MPI_SOURCE)
    call mpi_get_count(status,MPI_REAL4,count,ierr)
    if(count.ne.size(buf)) then
       write(msg,100) 'recv_r4a',size(buf),count
       call fabort(msg)
    endif
    value=buf  ! in case value isn't contiguous
100 format(a,': expected: ',i0,' got: ',i0,' values')
    return
    end subroutine recv_r4a
!-----------------------------------------------------------------------
    subroutine recv_r8a(value,src,sender)
!  RECV_R8A - receive a rank-1 double precision array from SRC.  SRC may be
!  MPI_ANY_SOURCE, in which case the optional argument SENDER should be
!  present; the latter is set to the id of the actual sender.  Otherwise,
!  if SRC is the id of another process, then SENDER is set to SRC on return.
!
    real(R8),intent(out)::value(:)
    integer,intent(in)::src
    integer,intent(out),optional::sender
!
    real(R8)::buf(size(value))
    integer::ierr,count,status(MPI_STATUS_SIZE)
    character(80)::msg
!
    call mpi_recv(buf,size(buf),MPI_REAL8,src,R8A_TAG,MPI_COMM_WORLD,status, &
       ierr)
    if(present(sender)) sender=status(MPI_SOURCE)
    call mpi_get_count(status,MPI_REAL8,count,ierr)
    if(count.ne.size(buf)) then
       write(msg,100) 'recv_r8a',size(buf),count
       call fabort(msg)
    endif
    value=buf  ! in case value isn't contiguous
100 format(a,': expected: ',i0,' got: ',i0,' values')
    return
    end subroutine recv_r8a
!-----------------------------------------------------------------------
    subroutine startup
    integer::ierr
!
    call mpi_init(ierr)
    call mpi_comm_rank(MPI_COMM_WORLD,me,ierr)
    call mpi_comm_size(MPI_COMM_WORLD,npes,ierr)
    return
    end subroutine startup
!-----------------------------------------------------------------------
    subroutine shutdown
    integer::ierr
!
    call mpi_finalize(ierr)
    return
    end subroutine shutdown
!-----------------------------------------------------------------------
    end module mp

