c-----------------------------------------------------------------------
c Partial null MPI library
c the following subroutines are implemented:
c MPI_INIT, MPI_FINALIZE, MPI_SEND, MPI_RECV, MPI_ISEND, MPI_IRECV
c MPI_TEST, MPI_WAIT, MPI_SENDRECV, MPI_SSEND, MPI_ISSEND, MPI_WAITALL
c MPI_WAITANY, MPI_GET_COUNT, MPI_INITIALIZED, MPI_COMM_SIZE
c MPI_COMM_RANK, MPI_BCAST, MPI_BARRIER, MPI_REDUCE, MPI_SCAN
c MPI_ALLREDUCE, MPI_GATHER, MPI_ALLGATHER, MPI_SCATTER, MPI_ALLTOALL
c MPI_GATHERV, MPI_ALLGATHERV, MPI_SCATTERV, MPI_ALLTOALLV
c MPI_REDUCE_SCATTER, MPI_ABORT, MPI_WTIME, MPI_WTICK
c MPI_PROBE, MPI_IPROBE
c written by viktor k. decyk, ucla
c copyright 1999, regents of the university of california.
c all rights reserved.
c no warranty for proper operation of this software is given or implied.
c software or information may be copied, distributed, and used at own
c risk; it may not be distributed without this notice included verbatim
c with each file.
c update: january 26, 1999
c-----------------------------------------------------------------------
      subroutine MPI_INIT(ierror)
c initialize the MPI execution environment
c ierror = error indicator
c input: none, output: ierror
      implicit none
      integer ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_FINALIZE(ierror)
c terminate MPI execution environment
c ierror = error indicator
c output: ierror
      implicit none
      integer ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_SEND(buf,count,datatype,dest,tag,comm,ierror)
c blocking standard mode send
c buf = initial address of send buffer
c count = number of entries to send
c datatype = datatype of each entry
c dest = rank of destination
c tag = message tag
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: buf, count, datatype, dest, tag, comm
c output: ierror
      implicit none
      integer buf(*)
      integer count, datatype, dest, tag, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_RECV(buf,count,datatype,source,tag,comm,status,ierr
     1or)
c blocking receive
c buf = initial address of receive buffer
c count = maximum number of entries to receive
c datatype = datatype of each entry
c source = rank of source
c tag = message tag
c comm = communicator (only MPI_COMM_WORLD currently supported)
c status = return status
c ierror = error indicator
c input: count, datatype, source, tag, comm
c output: buf, status, ierror
      implicit none
      integer buf(*), status(*)
      integer count, datatype, source, tag, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_ISEND(buf,count,datatype,dest,tag,comm,request,ierr
     1or)
c start a non-blocking send
c buf = initial address of send buffer
c count = number of entries to send
c datatype = datatype of each entry
c dest = rank of destination
c tag = message tag
c comm = communicator (only MPI_COMM_WORLD currently supported)
c request = request handle
c ierror = error indicator
c input: buf, count, datatype, dest, tag, comm
c output: request, ierror
      implicit none
      integer buf(*)
      integer count, datatype, dest, tag, comm, request, ierror
      ierror = 0
      request = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_IRECV(buf,count,datatype,source,tag,comm,request,ie
     1rror)
c begin a non-blocking receive
c buf = initial address of receive buffer
c count = maximum number of entries to receive
c datatype = datatype of each entry
c source = rank of source
c tag = message tag
c comm = communicator (only MPI_COMM_WORLD currently supported)
c request = request handle
c ierror = error indicator
c input: count, datatype, source, tag, comm
c output: buf, request, ierror
      implicit none
      integer buf(*)
      integer count, datatype, source, tag, comm, request, ierror
      ierror = 0
      request = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_TEST(request,flag,status,ierror)
c check to see if a nonblocking send or receive operation has completed
c request = request handle
c flag = true if operation completed
c status = status object
c ierror = error indicator
c input: request
c output: request, flag, status, ierror
      implicit none
      integer status(*)
      integer request, ierror
      logical flag
      ierror = 0
      request = 0
      flag = .true.
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_WAIT(request,status,ierror)
c wait for an MPI send or receive to complete
c request = request handle
c status = status object
c ierror = error indicator
c input: request
c output: request, status, ierror
      implicit none
      integer status(*)
      integer request, ierror
      ierror = 0
      request = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_SENDRECV (sendbuf,sendcount,sendtype,dest,sendtag,
     1recvbuf,recvcount,recvtype,source,recvtag,comm,status,ierror)
c blocking send and receive operation
c sendbuf = initial address of send buffer
c sendcount = number of entries to send
c sendtype = type of entries in send buffer
c dest = rank of destination
c sendtag = send tag
c recvbuf = initial address of receive buffer
c recvcount = max number of entries to receive
c recvtype = type of entries in receive buffer
c source = rank of source
c recvtag = receive tag
c comm = communicator (only MPI_COMM_WORLD currently supported)
c status = return status
c ierror = error indicator
c input: sendbuf, sendcount, sendtype, dest, sendtag, recvbuf, recvcount
c        recvtype, source, recvtag, comm
c output: recvbuf, status, ierror
      implicit none
      integer sendbuf(*), recvbuf(*), status(*)
      integer sendcount, sendtype, dest, sendtag, recvcount, recvtype
      integer source, recvtag, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_SSEND(buf,count,datatype,dest,tag,comm,ierror)
c blocking synchronous mode send
c buf = initial address of send buffer
c count = number of entries to send
c datatype = datatype of each entry
c dest = rank of destination
c tag = message tag
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: buf, count, datatype, dest, tag, comm
c output: ierror
      implicit none
      integer buf(*)
      integer count, datatype, dest, tag, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_ISSEND(buf,count,datatype,dest,tag,comm,request,ier
     1ror)
c start a non-blocking synchronous mode send
c buf = initial address of send buffer
c count = number of entries to send
c datatype = datatype of each entry
c dest = rank of destination
c tag = message tag
c comm = communicator (only MPI_COMM_WORLD currently supported)
c request = request handle
c ierror = error indicator
c input: buf, count, datatype, dest, tag, comm
c output: request, ierror
      implicit none
      integer buf(*)
      integer count, datatype, dest, tag, comm, request, ierror
      ierror = 0
      request = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_WAITALL (count,array_of_requests,array_of_statuses,
     1ierror)
c wait for a collection of specified MPI sends or receives to complete
c count = list length
c array_of_requests = array of request handles
c array_of_statuses = array of status objects
c ierror = error indicator
c input: count, array_of_requests
c output: array_of_requests, array_of_statuses, ierror
      implicit none
      integer array_of_requests(*), array_of_statuses(*)
      integer count, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_WAITANY(count,array_of_requests,index,status,ierror
     1)
c wait for any specified MPI send or receive to complete
c count = list length
c array_of_requests = array of request handles
c index = index of request handle that completed
c status = status object
c ierror = error indicator
c input: count, array_of_requests
c output: array_of_requests, index, status, ierror
      implicit none
      integer array_of_requests(*), status(*)
      integer count, index, ierror
      ierror = 0
      index = 1
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_GET_COUNT(status,datatype,count,ierror)
c get the number of "top level" elements
c status = return status of receive operation
c datatype = datatype of each receive buffer entry
c count = number of received entries
c ierror = error indicator
c input: status, datatype
c output: count, ierror
      implicit none
      integer status(*)
      integer datatype, count, ierror
      ierror = 0
      count = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_INITIALIZED(flag,ierror)
c indicate whether MPI_init has been called
c flag = true if MPI_Init has been called, false otherwise
c ierror = error indicator
c output: flag, ierror
      implicit none
      logical flag
      integer ierror
      ierror = 0
      flag = .true.
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_COMM_SIZE(comm,size,ierror)
c determine the size of the group associated with a communicator
c comm = communicator (this is ignored)
c size = number of processors in the group of comm
c ierror = error indicator
c input: comm
c output: size, ierror
      implicit none
      integer comm, size, ierror
      ierror = 0
      size = 1
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_COMM_RANK(comm,rank,ierror)
c determine the rank of the calling process in the communicator
c comm = communicator (this is ignored)
c rank = rank of the calling process in group of comm
c ierror = error indicator
c input: comm
c output: rank, ierror
      implicit none
      integer comm, rank, ierror
      ierror = 0
      rank = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_BCAST(buffer,count,datatype,root,comm,ierror)
c broadcast a message from root to all processes in comm
c buffer = starting address of buffer
c count = number of entries in buffer
c datatype = datatype of buffer
c root = rank of broadcast root
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: buffer, count, datatype, root, comm
c output: buffer, ierror
      implicit none
      integer buffer(*)
      integer count, datatype, root, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_BARRIER(comm,ierror)
c blocks each process in comm until all processes have called it.
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: comm
c output: ierror
      implicit none
      integer comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_REDUCE(sendbuf,recvbuf,count,datatype,op,root,comm,
     1ierror)
c applies a reduction operation to the vector sendbuf over the set of
c processes specified by comm and places the result in recvbuf on root
c sendbuf = address of send buffer
c recvbuf = address of receive buffer
c count = number of elements in send buffer
c datatype = datatype of elements in send buffer
c op = reduce operation (only max, min and sum currently supported)
c root = rank of root process
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, count, datatype, op, root, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*)
      integer count, datatype, op, root, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_SCAN(sendbuf,recvbuf,count,datatype,op,comm,ierror)
c performs a parallel prefix reduction on data distributed across a
c group
c sendbuf = address of send buffer
c recvbuf = address of receive buffer
c count = number of elements in send buffer
c datatype = datatype of elements in send buffer
c op = reduce operation (only max, min and sum currently supported)
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, count, datatype, op, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*)
      integer count, datatype, op, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_ALLREDUCE(sendbuf,recvbuf,count,datatype,op,comm,ie
     1rror)
c applies a reduction operation to the vector sendbuf over the set of
c processes specified by comm and places result in recvbuf on all nodes
c sendbuf = address of send buffer
c recvbuf = address of receive buffer
c count = number of elements in send buffer
c datatype = datatype of elements in send buffer
c op = reduce operation (only max, min and sum currently supported)
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, count, datatype, op, root, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*)
      integer count, datatype, op, comm, ierror, i
      do i = 1, count
      recvbuf(i) = sendbuf(i)
      end do
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_GATHER(sendbuf,sendcount,sendtype,recvbuf,recvcount
     1,recvtype,root,comm,ierror)
c collect individual messages from each process in comm at root
c sendbuf = starting address of send buffer
c sendcount = number of elements in send buffer
c sendtype = datatype of send buffer elements
c recvbuf = address of receive buffer
c recvcount = number of elements for any single receive
c recvtype = datatype of recv buffer elements
c root = rank of receiving process
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, sendcount, sendtype, recvcount, recvtype, root, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*)
      integer sendcount, sendtype, recvcount, recvtype, root, comm
      integer ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_ALLGATHER(sendbuf,sendcount,sendtype,recvbuf,recvco
     1unt,recvtype,comm,ierror)
c gather individual messages from each process in comm and distribute
c the resulting message to each process.
c sendbuf = starting address of send buffer
c sendcount = number of elements in send buffer
c sendtype = datatype of send buffer elements
c recvbuf = address of receive buffer
c recvcount = number of elements for any process
c recvtype = datatype of receive buffer elements
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, sendcount, sendtype, recvcount, recvtype, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*)
      integer sendcount, sendtype, recvcount, recvtype, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_SCATTER(sendbuf,sendcount,sendtype,recvbuf,recvcoun
     1t,recvtype,root,comm,ierror)
c distribute individual messages from root to each process in comm
c sendbuf = starting address of send buffer
c sendcount = number of elements in send buffer
c sendtype = datatype of send buffer elements
c recvbuf = address of receive buffer
c recvcount = number of elements for any single receive
c recvtype = datatype of recv buffer elements
c root = rank of sending process
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, sendcount, sendtype, recvcount, recvtype, root, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*)
      integer sendcount, sendtype, recvcount, recvtype, root, comm
      integer ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_ALLTOALL(sendbuf,sendcount,sendtype,recvbuf,recvcou
     1nt,recvtype,comm,ierror)
c send a distinct message from each process to every process
c sendbuf = starting address of send buffer
c sendcount = number of elements in send buffer
c sendtype = datatype of send buffer elements
c recvbuf = address of receive buffer
c recvcount = number of elements for any single receive
c recvtype = datatype of recv buffer elements
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, sendcount, sendtype, recvcount, recvtype, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*)
      integer sendcount, sendtype, recvcount, recvtype, comm
      integer ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_GATHERV(sendbuf,sendcount,sendtype,recvbuf,recvcoun
     1ts,displs,recvtype,root,comm,ierror)
c collect individual messages from each process in comm at root
c messages can have different sizes and displacements
c sendbuf = starting address of send buffer
c sendcount = number of elements in send buffer
c sendtype = datatype of send buffer elements
c recvbuf = address of receive buffer
c recvcounts = integer array
c displs = integer array of displacements
c recvtype = datatype of recv buffer elements
c root = rank of receiving process
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, sendcount, sendtype, recvcounts, displs, recvtype
c input: root, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*), recvcounts(*), displs(*)
      integer sendcount, sendtype, recvtype, root, comm
      integer ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_ALLGATHERV(sendbuf,sendcount,sendtype,recvbuf,recvc
     1ounts,displs,recvtype,comm,ierror)
c gather individual messages from each process in comm and distribute
c the resulting message to each process.
c messages can have different sizes and displacements
c sendbuf = starting address of send buffer
c sendcount = number of elements in send buffer
c sendtype = datatype of send buffer elements
c recvbuf = address of receive buffer
c recvcounts = integer array
c displs = integer array of displacements
c recvtype = datatype of receive buffer elements
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, sendcount, sendtype, recvcounts, displs, recvtype
c input: comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*), recvcounts(*), displs(*)
      integer sendcount, sendtype, recvtype, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_SCATTERV(sendbuf,sendcounts,displs,sendtype,recvbuf
     1,recvcount,recvtype,root,comm,ierror)
c distribute individual messages from root to each process in comm
c messages can have different sizes and displacements
c sendbuf = starting address of send buffer
c sendcounts = integer array
c displs = integer array of displacements
c sendtype = datatype of send buffer elements
c recvbuf = address of receive buffer
c recvcount = number of elements for any single receive
c recvtype = datatype of recv buffer elements
c root = rank of sending process
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, sendcounts, displs, sendtype, recvcount, recvtype
c input: root, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*), sendcounts(*), displs(*)
      integer sendtype, recvcount, recvtype, root, comm
      integer ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_ALLTOALLV(sendbuf,sendcounts,sdispls,sendtype,recvb
     1uf,recvcounts,rdispls,recvtype,comm,ierror)
c send a distinct message from each process to every process
c messages can have different sizes and displacements
c sendbuf = starting address of send buffer
c sendcounts = integer array
c sdispls = integer array of send displacements
c sendtype = datatype of send buffer elements
c recvbuf = address of receive buffer
c recvcounts = integer array
c rdispls = integer array of receive displacements
c recvtype = datatype of recv buffer elements
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, sendcount, sendtype, recvcount, recvtype, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*)
      integer sendcounts(*), sdispls(*), recvcounts(*), rdispls(*)
      integer sendtype, recvtype, comm
      integer ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_REDUCE_SCATTER(sendbuf,recvbuf,recvcounts,datatype,
     1op,comm,ierror)
c applies a reduction operation to the vector sendbuf over the set of
c processes specified by comm and scatters the result according to the
c values in recvcounts
c sendbuf = starting address of send buffer
c recvbuf = starting address of receive buffer
c recvcounts = integer array
c datatype = datatype of elements in input buffer
c op = reduce operation (only max, min and sum currently supported)
c comm = communicator (only MPI_COMM_WORLD currently supported)
c ierror = error indicator
c input: sendbuf, recvcounts, datatype, op, comm
c output: recvbuf, ierror
      implicit none
      integer sendbuf(*), recvbuf(*), recvcounts(*)
      integer datatype, op, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_ABORT(comm,errorcode,ierror)
c force all tasks on an MPI environment to terminate
c comm = communicator (only MPI_COMM_WORLD currently supported)
c errorcode = error code to return to invoking environment
c ierror = error indicator
c input: comm, errorcode
c output: ierror
      implicit none
      integer comm, errorcode, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      function MPI_WTIME()
c return an elapsed time on the calling processor in seconds
      implicit none
      double precision MPI_WTIME
      MPI_WTIME = 0.0d0
      return
      end
c-----------------------------------------------------------------------
      function MPI_WTICK()
c return the resolution of MPI_WTIME in seconds
      implicit none
      double precision MPI_WTICK
      MPI_WTICK = 0.0d0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_PROBE(source,tag,comm,status,ierror)
c check for a message without actually receiving it
c source = message id
c tag = message tag
c comm = communicator (only MPI_COMM_WORLD currently supported)
c status = return status of receive operation
c ierror = error indicator
c input: source, tag, comm
c output: status, ierror
      implicit none
      integer status(*)
      integer source, tag, comm, ierror
      ierror = 0
      return
      end
c-----------------------------------------------------------------------
      subroutine MPI_IPROBE(source,tag,comm,flag,status,ierror)
c check for a message without actually receiving it
c source = message id
c tag = message tag
c comm = communicator (only MPI_COMM_WORLD currently supported)
c flag = true if operation completed
c status = return status of receive operation
c ierror = error indicator
c input: source, tag, comm
c output: status, flag, ierror
      implicit none
      integer status(*)
      integer source, tag, comm, ierror
      logical flag
      ierror = 0
      flag = .true.
      return
      end
