mpi_dummy.F90

Go to the documentation of this file.

!*********************************************************************72
    subroutine mpi_scan(data1, data2, n, datatype, &
    operation, comm, ierror )

    implicit none

    include "mpi_dummy.h"

    integer :: n

    integer :: comm
    integer :: data1(n)
    integer :: data2(n)
    integer :: datatype
    integer :: ierror
    integer :: operation    ! currently hardwired only for sum only

    ierror = mpi_success

    if ( datatype == mpi_double_precision ) then

        call copy(  data2, data1, n )

    else if ( datatype == mpi_integer ) then

        data2 = data1

    else if ( datatype == mpi_integer8 ) then

        data2 = data1

    else if ( datatype == mpi_real ) then

        data2 = data1

    else

        ierror = mpi_failure

    end if

    return
    end subroutine mpi_scan

!*********************************************************************72
    subroutine mpi_abort ( comm, errorcode, ierror )

!*********************************************************************72

!c MPI_ABORT shuts down the processes in a given communicator.

    implicit none

    integer :: comm
    integer :: errorcode
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_ABORT:'
    write ( *, '(a,i12)' ) &
    '  Shut down with error code = ', errorcode

    stop
    end subroutine mpi_abort
    subroutine mpi_allgather ( data1, nsend, sendtype, data2, &
    nrecv, recvtype, comm, ierror )

!*********************************************************************72

!c MPI_ALLGATHER gathers data from all the processes in a communicator.

    implicit none

    include "mpi_dummy.h"

    integer :: nsend

    integer :: comm
    integer :: data1(nsend)
    integer :: data2(nsend)
    integer :: ierror
    integer :: nrecv
    integer :: recvtype
    integer :: sendtype

    ierror = mpi_success

    if ( sendtype == mpi_double_precision ) then
        call mpi_copy_double_precision( data1, data2, nsend, ierror )
    else if ( sendtype == mpi_integer ) then
        call mpi_copy_integer( data1, data2, nsend, ierror )
    else if ( sendtype == mpi_real ) then
        call mpi_copy_real( data1, data2, nsend, ierror )
    else
        ierror = mpi_failure
    end if

    return
    end subroutine mpi_allgather
    subroutine mpi_allgatherv ( data1, nsend, sendtype, &
    data2, nrecv, ndispls, recvtype, comm, ierror )

!*********************************************************************72

!c MPI_ALLGATHERV gathers data from all the processes in a communicator.

    implicit none

    include "mpi_dummy.h"

    integer :: nsend

    integer :: comm
    integer :: data1(nsend)
    integer :: data2(nsend)
    integer :: ierror
    integer :: ndispls
    integer :: nrecv
    integer :: recvtype
    integer :: sendtype

    ierror = mpi_success

    if ( sendtype == mpi_double_precision ) then
        call mpi_copy_double_precision( data1, data2, nsend, ierror )
    else if ( sendtype == mpi_integer ) then
        call mpi_copy_integer( data1, data2, nsend, ierror )
    else if ( sendtype == mpi_real ) then
        call mpi_copy_real( data1, data2, nsend, ierror )
    else
        ierror = mpi_failure
    end if

    return
    end subroutine mpi_allgatherv
    subroutine mpi_allreduce ( data1, data2, n, datatype, &
    operation, comm, ierror )

!*********************************************************************72

!c MPI_ALLREDUCE carries out a reduction operation.

    implicit none

    include "mpi_dummy.h"

    integer :: n

    integer :: comm
    integer :: data1(n)
    integer :: data2(n)
    integer :: datatype
    integer :: ierror
    integer :: operation

    ierror = mpi_success

    if ( datatype == mpi_double_precision ) then

        call mpi_reduce_double_precision( &
        data1, data2, n, operation, ierror )

    else if ( datatype == mpi_integer ) then

        call mpi_reduce_integer( &
        data1, data2, n, operation, ierror )

    else if ( datatype == mpi_integer8 ) then

        call mpi_reduce_integer8( &
        data1, data2, n, operation, ierror )

    else if ( datatype == mpi_real ) then

        call mpi_reduce_real( &
        data1, data2, n, operation, ierror )

    else

        ierror = mpi_failure

    end if

    return
    end subroutine mpi_allreduce

    subroutine mpi_barrier ( comm, ierror )

!*********************************************************************72

!c MPI_BARRIER forces processes within a communicator to wait together.

    implicit none

    integer :: comm
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_failure

    return
    end subroutine mpi_barrier
    subroutine mpi_bcast ( data, n, datatype, node, comm, ierror )

!*********************************************************************72

!c MPI_BCAST broadcasts data from one process to all others.

    implicit none

    integer :: n

    integer :: comm
    integer :: data(n)
    integer :: datatype
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )
    integer :: node

    ierror = mpi_success

    return
    end subroutine mpi_bcast
    subroutine mpi_bsend ( data, n, datatype, iproc, itag, &
    comm, ierror )

!*********************************************************************72

!c MPI_BSEND sends data from one process to another, using buffering.

    implicit none

    integer :: n

    integer :: comm
    integer :: data(n)
    integer :: datatype
    integer :: ierror
    integer :: iproc
    integer :: itag
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_failure

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_BSEND - Error!'
    write ( *, '(a)' )  '  Should not send message to self.'

    return
    end subroutine mpi_bsend
    subroutine mpi_cart_create ( comm, ndims, dims, periods, &
    reorder, comm_cart, ierror )

!*********************************************************************72

!c MPI_CART_CREATE creates a communicator for a Cartesian topology.

    implicit none

    integer :: ndims

    integer :: comm
    integer :: comm_cart
    integer :: dims(*)
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )
    logical :: periods(*)
    logical :: reorder

    ierror = mpi_success

    return
    end subroutine mpi_cart_create
    subroutine mpi_cart_get ( comm, ndims, dims, periods, &
    coords, ierror )

!*********************************************************************72

!c MPI_CART_GET returns the "Cartesian coordinates" of the calling process.

    implicit none

    integer :: ndims

    integer :: comm
    integer :: coords(*)
    integer :: dims(*)
    integer :: i
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )
    logical :: periods(*)

    ierror = mpi_success

    do i = 1, ndims
        coords(i) = 0
    end do

    return
    end subroutine mpi_cart_get
    subroutine mpi_cart_shift ( comm, idir, idisp, isource, &
    idest, ierror )

!*********************************************************************72

!c MPI_CART_SHIFT finds the destination and source for Cartesian shifts.

    implicit none

    integer :: comm
    integer :: idest
    integer :: idir
    integer :: idisp
    integer :: ierror
    integer :: isource
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success
    isource = 0
    idest = 0

    return
    end subroutine mpi_cart_shift
    subroutine mpi_comm_dup ( comm, comm_out, ierror )

!*********************************************************************72

!c MPI_COMM_DUP duplicates a communicator.

    implicit none

    integer :: comm
    integer :: comm_out
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success
    comm_out = comm

    return
    end subroutine mpi_comm_dup
    subroutine mpi_comm_free ( comm, ierror )

!*********************************************************************72

!c MPI_COMM_FREE "frees" a communicator.

    implicit none

    integer :: comm
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success

    return
    end subroutine mpi_comm_free
    subroutine mpi_comm_rank ( comm, me, ierror )

!*********************************************************************72

!c MPI_COMM_RANK reports the rank of the calling process.

    implicit none

    integer :: comm
    integer :: ierror
    integer :: me
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success
    me = 0

    return
    end subroutine mpi_comm_rank
    subroutine mpi_comm_size ( comm, nprocs, ierror )

!*********************************************************************72

!c MPI_COMM_SIZE reports the number of processes in a communicator.

    implicit none

    integer :: comm
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )
    integer :: nprocs

    ierror = mpi_success
    nprocs = 1

    return
    end subroutine mpi_comm_size
    subroutine mpi_comm_split ( comm, icolor, ikey, comm_new, &
    ierror )

!*********************************************************************72

!c MPI_COMM_SPLIT splits up a communicator based on a key.

    implicit none

    integer :: comm
    integer :: comm_new
    integer :: icolor
    integer :: ierror
    integer :: ikey
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success

    return
    end subroutine mpi_comm_split
    subroutine mpi_copy_double_precision ( data1, data2, n, ierror )

!*********************************************************************72

!c MPI_COPY_DOUBLE copies a real*8 vector.

    implicit none

    integer :: n

    real*8 :: data1(n)
    real*8 :: data2(n)
    integer :: i
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success

    do i = 1, n
        data2(i) = data1(i)
    end do

    return
    end subroutine mpi_copy_double_precision
    subroutine mpi_copy_integer ( data1, data2, n, ierror )

!*********************************************************************72

!c MPI_COPY_INTEGER copies an integer vector.

    implicit none

    integer :: n

    integer :: data1(n)
    integer :: data2(n)
    integer :: i
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success

    do i = 1, n
        data2(i) = data1(i)
    end do

    return
    end subroutine mpi_copy_integer
    subroutine mpi_copy_real ( data1, data2, n, ierror )

!*********************************************************************72

    implicit none

    integer :: n

    real :: data1(n)
    real :: data2(n)
    integer :: i
    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success

    do i = 1, n
        data2(i) = data1(i)
    end do

    return
    end subroutine mpi_copy_real
    subroutine mpi_finalize ( ierror )

!*********************************************************************72

!c MPI_FINALIZE shuts down the MPI library.

    implicit none

    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success

    return
    end subroutine mpi_finalize
    subroutine mpi_get_count ( istatus, datatype, icount, ierror )

!*********************************************************************72

!c MPI_GET_COUNT reports the actual number of items transmitted.

    implicit none

    integer :: datatype
    integer :: icount
    integer :: ierror
    integer :: istatus
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_failure

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_GET_COUNT - Error!'
    write ( *, '(a)' ) '  Should not query message from self.'

    return
    end subroutine mpi_get_count
    subroutine mpi_init ( ierror )

!*********************************************************************72

!c MPI_INIT initializes the MPI library.

    implicit none

    integer :: ierror
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_success

    return
    end subroutine mpi_init
    subroutine mpi_irecv ( data, n, datatype, iproc, itag, &
    comm, irequest, ierror )

!*********************************************************************72

!c MPI_IRECV receives data from another process.

    implicit none

    integer :: n

    integer :: comm
    integer :: data(n)
    integer :: datatype
    integer :: ierror
    integer :: iproc
    integer :: irequest
    integer :: itag
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_failure

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_IRECV - Error!'
    write ( *, '(a)' ) '  Should not recv message from self.'

    return
    end subroutine mpi_irecv
    subroutine mpi_isend ( data, n, datatype, iproc, itag, &
    comm, request, ierror )

!*********************************************************************72

!c MPI_ISEND sends data from one process to another using nonblocking transmission.

    implicit none

    integer :: n

    integer :: comm
    integer :: data(n)
    integer :: datatype
    integer :: ierror
    integer :: iproc
    integer :: itag
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )
    integer :: request

    request = 0
    ierror = mpi_failure

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_ISEND - Error!'
    write ( *, '(a)' )  '  Should not send message to self.'

    return
    end subroutine mpi_isend
    subroutine mpi_recv ( data, n, datatype, iproc, itag, &
    comm, istatus, ierror )

!*********************************************************************72

!c MPI_RECV receives data from another process within a communicator.

    implicit none

    integer :: n

    integer :: comm
    integer :: data(n)
    integer :: datatype
    integer :: ierror
    integer :: iproc
    integer :: istatus
    integer :: itag
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_failure

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_RECV - Error!'
    write ( *, '(a)' ) '  Should not recv message from self.'

    return
    end subroutine mpi_recv
    subroutine mpi_reduce ( data1, data2, n, datatype, operation, &
    receiver, comm, ierror )

!*********************************************************************72

!c MPI_REDUCE carries out a reduction operation.

    implicit none

    include "mpi_dummy.h"

    integer :: n

    integer :: comm
    integer :: data1(n)
    integer :: data2
    integer :: datatype
    integer :: ierror
    integer :: operation
    integer :: receiver

    ierror = mpi_success

    if ( datatype == mpi_double_precision ) then

        call mpi_reduce_double_precision( &
        data1, data2, n, operation, ierror )

    else if ( datatype == mpi_integer ) then

        call mpi_reduce_integer( &
        data1, data2, n, operation, ierror )

    else if ( datatype == mpi_real ) then

        call mpi_reduce_real( &
        data1, data2, n, operation, ierror )

    else

        ierror = mpi_failure

    end if

    return
    end subroutine mpi_reduce
    subroutine mpi_reduce_double_precision ( &
    data1, data2, n, operation, ierror )

!*********************************************************************72

!c MPI_REDUCE_DOUBLE_PRECISION carries out a reduction operation on real*8 values.

    implicit none

    include "mpi_dummy.h"

    integer :: n

    real*8 :: data1(n)
    real*8 :: data2(n)
    integer :: i
    integer :: ierror
    integer :: operation


    ierror = mpi_success

    do i = 1, n
        data2(i) = data1(i)
    end do

    return
    end subroutine mpi_reduce_double_precision

    subroutine mpi_reduce_integer8 ( &
    data1, data2, n, operation, ierror )

!*********************************************************************72

    implicit none

    include "mpi_dummy.h"

    integer :: n

    integer*8 :: data1(n)
    integer*8 :: data2(n)
    integer :: i
    integer :: ierror
    integer :: operation

    ierror = mpi_success

    do i = 1, n
        data2(i) = data1(i)
    end do

    ierror = mpi_failure

    return
    end subroutine mpi_reduce_integer8
     
    subroutine mpi_reduce_integer ( &
    data1, data2, n, operation, ierror )

!*********************************************************************72

    implicit none

    include "mpi_dummy.h"

    integer :: n

    integer :: data1(n)
    integer :: data2(n)
    integer :: i
    integer :: ierror
    integer :: operation

    ierror = mpi_success

    do i = 1, n
        data2(i) = data1(i)
    end do

    ierror = mpi_failure

    return
    end subroutine mpi_reduce_integer

    subroutine mpi_reduce_real ( &
    data1, data2, n, operation, ierror )

!*********************************************************************72

!c MPI_REDUCE_REAL carries out a reduction operation on reals.

!  Discussion:

    implicit none

    include "mpi_dummy.h"

    integer :: n

    real :: data1(n)
    real :: data2(n)
    integer :: i
    integer :: ierror
    integer :: operation

    ierror = mpi_success

    do i = 1, n
        data2(i) = data1(i)
    end do

    return
    end subroutine mpi_reduce_real
    subroutine mpi_reduce_scatter ( data1, data2, n, datatype, &
    operation, comm, ierror )

!*********************************************************************72

!c MPI_REDUCE_SCATTER collects a message of the same length from each process.

    implicit none

    include "mpi_dummy.h"

    integer :: n

    integer :: comm
    integer :: data1(n)
    integer :: data2(n)
    integer :: datatype
    integer :: ierror
    integer :: operation

    ierror = mpi_success

    if ( datatype == mpi_double_precision ) then
        call mpi_copy_double_precision( data1, data2, n, ierror )
    else if ( datatype == mpi_integer ) then
        call mpi_copy_integer( data1, data2, n, ierror )
    else if ( datatype == mpi_real ) then
        call mpi_copy_real( data1, data2, n, ierror )
    else
        ierror = mpi_failure
    end if

    return
    end subroutine mpi_reduce_scatter
    subroutine mpi_rsend ( data, n, datatype, iproc, itag, &
    comm, ierror )

!*********************************************************************72

!c MPI_RSEND "ready sends" data from one process to another.

    implicit none

    integer :: n

    integer :: comm
    integer :: data(n)
    integer :: datatype
    integer :: ierror
    integer :: iproc
    integer :: itag
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_failure

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_RSEND - Error!'
    write ( *, '(a)' ) '  Should not send message to self.'

    return
    end subroutine mpi_rsend
    subroutine mpi_send ( data, n, datatype, iproc, itag, &
    comm, ierror )

!*********************************************************************72

!c MPI_SEND sends data from one process to another.

    implicit none

    integer :: n

    integer :: comm
    integer :: data(n)
    integer :: datatype
    integer :: ierror
    integer :: iproc
    integer :: itag
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_failure

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_SEND - Error!'
    write ( *, '(a)' )  '  Should not send message to self.'

    return
    end subroutine mpi_send
    subroutine mpi_wait ( irequest, istatus, ierror )

!*********************************************************************72

!c MPI_WAIT waits for an I/O request to complete.

    implicit none

    integer :: ierror
    integer :: irequest
    integer :: istatus
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_failure

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_WAIT - Error!'
    write ( *, '(a)' ) '  Should not wait on message from self.'

    return
    end subroutine mpi_wait
    subroutine mpi_waitall ( icount, irequest, istatus, ierror )

!*********************************************************************72

!c MPI_WAITALL waits until all I/O requests have completed.

    implicit none

    integer :: icount
    integer :: ierror
    integer :: irequest
    integer :: istatus
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_failure

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_WAITALL - Error!'
    write ( *, '(a)' ) '  Should not wait on message from self.'

    return
    end subroutine mpi_waitall
    subroutine mpi_waitany ( icount, array_of_requests, index, &
    istatus, ierror )

!*********************************************************************72

!c MPI_WAITANY waits until one I/O requests has completed.

    implicit none

    integer :: array_of_requests(*)
    integer :: icount
    integer :: ierror
    integer :: index
    integer :: istatus
    integer :: MPI_FAILURE
    parameter( mpi_failure = 1 )
    integer :: MPI_SUCCESS
    parameter( mpi_success = 0 )

    ierror = mpi_failure

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'MPI_WAITANY - Error!'
    write ( *, '(a)' ) '  Should not wait on message from self.'

    return
    end subroutine mpi_waitany
    function mpi_wtick ( )

!*********************************************************************72

!c MPI_WTICK returns the time between clock ticks.

    implicit none
          
    real*8 :: mpi_wtick
          
    mpi_wtick = 1.0d+00
          
    return
    end function mpi_wtick
    function mpi_wtime ( )

!*********************************************************************72

!c MPI_WTIME returns the elapsed wall clock time.

    implicit none

    real*8 :: mpi_wtime
    real*4 :: a(2),etime
    a(1)=0.0
    a(2)=0.0
    mpi_wtime = etime(a)

    return
    end function mpi_wtime

    subroutine mpi_initialized(mpi_is_initialized, ierr)

    mpi_is_initialized = 0
    ierr = 0

    return
    end subroutine mpi_initialized

    subroutine mpi_comm_create(icomm,igroup,icommd,ierr)

    icommd = 1

    return
    end subroutine mpi_comm_create

    subroutine mpi_comm_group(icomm,igroup,ierr)

    igroup = 1
    ierr = 0

    return
    end subroutine mpi_comm_group

    subroutine mpi_group_free

    return
    end subroutine mpi_group_free

    subroutine mpi_attr_get(icomm,ikey,ival,iflag,ierr)
     
    logical :: iflag

    ival =  9 999 999  ! dummy
     
    return
    end subroutine mpi_attr_get
!-----------------------------------------------------------------------