C -*- Mode: Fortran; -*-
C
C (C) 2012 by Argonne National Laboratory.
C See COPYRIGHT in top-level directory.
C
C This program is based on the allpair.f test from the MPICH-1 test
C (test/pt2pt/allpair.f), which in turn was inspired by a bug report from
C fsset@corelli.lerc.nasa.gov (Scott Townsend)
program allpair
implicit none
include 'mpif.h'
integer ierr, errs, comm
logical mtestGetIntraComm
logical verbose
common /flags/ verbose
errs = 0
verbose = .false.
C verbose = .true.
call MTest_Init( ierr )
do while ( mtestGetIntraComm( comm, 2, .false. ) )
call test_pair_send( comm, errs )
call test_pair_ssend( comm, errs )
call test_pair_rsend( comm, errs )
call test_pair_isend( comm, errs )
call test_pair_irsend( comm, errs )
call test_pair_issend( comm, errs )
call test_pair_psend( comm, errs )
call test_pair_prsend( comm, errs )
call test_pair_pssend( comm, errs )
call test_pair_sendrecv( comm, errs )
call test_pair_sendrecvrepl( comm, errs )
call mtestFreeComm( comm )
enddo
C
call MTest_Finalize( errs )
call MPI_Finalize(ierr)
C
end
C
subroutine test_pair_send( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count
integer TEST_SIZE
parameter (TEST_SIZE=2000)
integer status(MPI_STATUS_SIZE)
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' Send and recv'
endif
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
tag = 1123
count = TEST_SIZE / 5
C
call clear_test_data(recv_buf,TEST_SIZE)
C
if (rank .eq. 0) then
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Send(send_buf, count, MPI_REAL, next, tag,
. comm, ierr)
C
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
C
call msg_check( recv_buf, next, tag, count, status, TEST_SIZE,
. 'send and recv', errs )
else if (prev .eq. 0) then
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'send and recv', errs )
C
call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr)
end if
C
end
C
subroutine test_pair_rsend( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count, i
integer TEST_SIZE
parameter (TEST_SIZE=2000)
integer status(MPI_STATUS_SIZE), requests(1)
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' Rsend and recv'
endif
C
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
tag = 1456
count = TEST_SIZE / 3
C
call clear_test_data(recv_buf,TEST_SIZE)
C
if (rank .eq. 0) then
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
. comm, status, ierr )
C
call MPI_Rsend(send_buf, count, MPI_REAL, next, tag,
. comm, ierr)
C
call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr)
C
if (status(MPI_SOURCE) .ne. next) then
print *, 'Rsend: Incorrect source, expected', next,
. ', got', status(MPI_SOURCE)
errs = errs + 1
end if
C
if (status(MPI_TAG) .ne. tag) then
print *, 'Rsend: Incorrect tag, expected', tag,
. ', got', status(MPI_TAG)
errs = errs + 1
end if
C
call MPI_Get_count(status, MPI_REAL, i, ierr)
C
if (i .ne. count) then
print *, 'Rsend: Incorrect count, expected', count,
. ', got', i
errs = errs + 1
end if
C
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. status, ierr)
C
call msg_check( recv_buf, next, tag, count, status, TEST_SIZE,
. 'rsend and recv', errs )
C
else if (prev .eq. 0) then
C
call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. requests(1), ierr)
call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag,
. comm, ierr )
call MPI_Wait( requests(1), status, ierr )
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'rsend and recv', errs )
C
call MPI_Send(recv_buf, count, MPI_REAL, prev, tag,
. comm, ierr)
end if
C
end
C
subroutine test_pair_ssend( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count, i
integer TEST_SIZE
parameter (TEST_SIZE=2000)
integer status(MPI_STATUS_SIZE)
logical flag
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' Ssend and recv'
endif
C
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
tag = 1789
count = TEST_SIZE / 3
C
call clear_test_data(recv_buf,TEST_SIZE)
C
if (rank .eq. 0) then
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Iprobe(MPI_ANY_SOURCE, tag,
. comm, flag, status, ierr)
C
if (flag) then
print *, 'Ssend: Iprobe succeeded! source',
. status(MPI_SOURCE),
. ', tag', status(MPI_TAG)
errs = errs + 1
end if
C
call MPI_Ssend(send_buf, count, MPI_REAL, next, tag,
. comm, ierr)
C
do while (.not. flag)
call MPI_Iprobe(MPI_ANY_SOURCE, tag,
. comm, flag, status, ierr)
end do
C
if (status(MPI_SOURCE) .ne. next) then
print *, 'Ssend: Incorrect source, expected', next,
. ', got', status(MPI_SOURCE)
errs = errs + 1
end if
C
if (status(MPI_TAG) .ne. tag) then
print *, 'Ssend: Incorrect tag, expected', tag,
. ', got', status(MPI_TAG)
errs = errs + 1
end if
C
call MPI_Get_count(status, MPI_REAL, i, ierr)
C
if (i .ne. count) then
print *, 'Ssend: Incorrect count, expected', count,
. ', got', i
errs = errs + 1
end if
C
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. status, ierr)
C
call msg_check( recv_buf, next, tag, count, status,
. TEST_SIZE, 'ssend and recv', errs )
C
else if (prev .eq. 0) then
C
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. status, ierr)
C
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'ssend and recv', errs )
C
call MPI_Ssend(recv_buf, count, MPI_REAL, prev, tag,
. comm, ierr)
end if
C
end
C
subroutine test_pair_isend( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count
integer TEST_SIZE
parameter (TEST_SIZE=2000)
integer status(MPI_STATUS_SIZE), requests(2)
integer statuses(MPI_STATUS_SIZE,2)
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' isend and irecv'
endif
C
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
tag = 2123
count = TEST_SIZE / 5
C
call clear_test_data(recv_buf,TEST_SIZE)
C
if (rank .eq. 0) then
C
call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. requests(1), ierr)
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Isend(send_buf, count, MPI_REAL, next, tag,
. comm, requests(2), ierr)
C
call MPI_Waitall(2, requests, statuses, ierr)
C
call rq_check( requests, 2, 'isend and irecv' )
C
call msg_check( recv_buf, next, tag, count, statuses(1,1),
. TEST_SIZE, 'isend and irecv', errs )
C
else if (prev .eq. 0) then
C
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. status, ierr)
C
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'isend and irecv', errs )
C
call MPI_Isend(recv_buf, count, MPI_REAL, prev, tag,
. comm, requests(1), ierr)
C
call MPI_Wait(requests(1), status, ierr)
C
call rq_check( requests(1), 1, 'isend and irecv' )
C
end if
C
end
C
subroutine test_pair_irsend( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count, index, i
integer TEST_SIZE
integer dupcom
parameter (TEST_SIZE=2000)
integer status(MPI_STATUS_SIZE), requests(2)
integer statuses(MPI_STATUS_SIZE,2)
logical flag
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' Irsend and irecv'
endif
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
call mpi_comm_dup( comm, dupcom, ierr )
C
tag = 2456
count = TEST_SIZE / 3
C
call clear_test_data(recv_buf,TEST_SIZE)
C
if (rank .eq. 0) then
C
call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. requests(1), ierr)
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
. MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
. dupcom, status, ierr )
C
call MPI_Irsend(send_buf, count, MPI_REAL, next, tag,
. comm, requests(2), ierr)
C
index = -1
do while (index .ne. 1)
call MPI_Waitany(2, requests, index, statuses, ierr)
end do
C
call rq_check( requests(1), 1, 'irsend and irecv' )
C
call msg_check( recv_buf, next, tag, count, statuses,
. TEST_SIZE, 'irsend and irecv', errs )
C
else if (prev .eq. 0) then
C
call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. requests(1), ierr)
C
call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, prev, 0,
. MPI_BOTTOM, 0, MPI_INTEGER, prev, 0,
. dupcom, status, ierr )
C
flag = .FALSE.
do while (.not. flag)
call MPI_Test(requests(1), flag, status, ierr)
end do
C
call rq_check( requests, 1, 'irsend and irecv (test)' )
C
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'irsend and irecv', errs )
C
call MPI_Irsend(recv_buf, count, MPI_REAL, prev, tag,
. comm, requests(1), ierr)
C
call MPI_Waitall(1, requests, statuses, ierr)
C
call rq_check( requests, 1, 'irsend and irecv' )
C
end if
C
call mpi_comm_free( dupcom, ierr )
C
end
C
subroutine test_pair_issend( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count, index
integer TEST_SIZE
parameter (TEST_SIZE=2000)
integer status(MPI_STATUS_SIZE), requests(2)
integer statuses(MPI_STATUS_SIZE,2)
logical flag
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' issend and irecv (testall)'
endif
C
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
tag = 2789
count = TEST_SIZE / 3
C
call clear_test_data(recv_buf,TEST_SIZE)
C
if (rank .eq. 0) then
C
call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. requests(1), ierr)
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Issend(send_buf, count, MPI_REAL, next, tag,
. comm, requests(2), ierr)
C
flag = .FALSE.
do while (.not. flag)
call MPI_Testall(2, requests, flag, statuses, ierr)
end do
C
call rq_check( requests, 2, 'issend and irecv (testall)' )
C
call msg_check( recv_buf, next, tag, count, statuses(1,1),
. TEST_SIZE, 'issend and recv (testall)', errs )
C
else if (prev .eq. 0) then
C
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. status, ierr)
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'issend and recv', errs )
call MPI_Issend(recv_buf, count, MPI_REAL, prev, tag,
. comm, requests(1), ierr)
C
flag = .FALSE.
do while (.not. flag)
call MPI_Testany(1, requests(1), index, flag,
. statuses(1,1), ierr)
end do
C
call rq_check( requests, 1, 'issend and recv (testany)' )
C
end if
C
end
C
subroutine test_pair_psend( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count, i
integer TEST_SIZE
parameter (TEST_SIZE=2000)
integer status(MPI_STATUS_SIZE)
integer statuses(MPI_STATUS_SIZE,2), requests(2)
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' Persistent send and recv'
endif
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
tag = 3123
count = TEST_SIZE / 5
C
call clear_test_data(recv_buf,TEST_SIZE)
call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. requests(2), ierr)
C
if (rank .eq. 0) then
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Send_init(send_buf, count, MPI_REAL, next, tag,
. comm, requests(1), ierr)
C
call MPI_Startall(2, requests, ierr)
call MPI_Waitall(2, requests, statuses, ierr)
C
call msg_check( recv_buf, next, tag, count, statuses(1,2),
. TEST_SIZE, 'persistent send/recv', errs )
C
call MPI_Request_free(requests(1), ierr)
C
else if (prev .eq. 0) then
C
call MPI_Send_init(send_buf, count, MPI_REAL, prev, tag,
. comm, requests(1), ierr)
call MPI_Start(requests(2), ierr)
call MPI_Wait(requests(2), status, ierr)
C
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
* 'persistent send/recv', errs )
C
do i = 1,count
send_buf(i) = recv_buf(i)
end do
C
call MPI_Start(requests(1), ierr)
call MPI_Wait(requests(1), status, ierr)
C
call MPI_Request_free(requests(1), ierr)
end if
C
call dummyRef( send_buf, count, ierr )
call MPI_Request_free(requests(2), ierr)
C
end
C
subroutine test_pair_prsend( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count, index, i
integer outcount, indices(2)
integer TEST_SIZE
parameter (TEST_SIZE=2000)
integer statuses(MPI_STATUS_SIZE,2), requests(2)
integer status(MPI_STATUS_SIZE)
logical flag
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' Persistent Rsend and recv'
endif
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
tag = 3456
count = TEST_SIZE / 3
C
call clear_test_data(recv_buf,TEST_SIZE)
C
call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. requests(2), ierr)
C
if (rank .eq. 0) then
C
call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag,
. comm, requests(1), ierr)
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
. comm, status, ierr )
C
call MPI_Startall(2, requests, ierr)
C
index = -1
C
do while (index .ne. 2)
call MPI_Waitsome(2, requests, outcount,
. indices, statuses, ierr)
do i = 1,outcount
if (indices(i) .eq. 2) then
call msg_check( recv_buf, next, tag, count,
. statuses(1,i), TEST_SIZE, 'waitsome', errs )
index = 2
end if
end do
end do
C
call MPI_Request_free(requests(1), ierr)
else if (prev .eq. 0) then
C
call MPI_Rsend_init(send_buf, count, MPI_REAL, prev, tag,
. comm, requests(1), ierr)
C
call MPI_Start(requests(2), ierr)
C
call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag,
. comm, ierr )
C
flag = .FALSE.
do while (.not. flag)
call MPI_Test(requests(2), flag, status, ierr)
end do
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'test', errs )
C
do i = 1,count
send_buf(i) = recv_buf(i)
end do
C
call MPI_Start(requests(1), ierr)
call MPI_Wait(requests(1), status, ierr)
C
call MPI_Request_free(requests(1), ierr)
end if
C
call dummyRef( send_buf, count, ierr )
call MPI_Request_free(requests(2), ierr)
C
end
C
subroutine test_pair_pssend( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count, index, i
integer outcount, indices(2)
integer TEST_SIZE
parameter (TEST_SIZE=2000)
integer statuses(MPI_STATUS_SIZE,2), requests(2)
integer status(MPI_STATUS_SIZE)
logical flag
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' Persistent Ssend and recv'
endif
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
tag = 3789
count = TEST_SIZE / 3
C
call clear_test_data(recv_buf,TEST_SIZE)
C
call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. requests(1), ierr)
C
if (rank .eq. 0) then
C
call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag,
. comm, requests(2), ierr)
C
call init_test_data(send_buf,TEST_SIZE)
C
call MPI_Startall(2, requests, ierr)
C
index = -1
do while (index .ne. 1)
call MPI_Testsome(2, requests, outcount,
. indices, statuses, ierr)
do i = 1,outcount
if (indices(i) .eq. 1) then
call msg_check( recv_buf, next, tag, count,
. statuses(1,i), TEST_SIZE, 'testsome', errs )
index = 1
end if
end do
end do
C
call MPI_Request_free(requests(2), ierr)
C
else if (prev .eq. 0) then
C
call MPI_Ssend_init(send_buf, count, MPI_REAL, prev, tag,
. comm, requests(2), ierr)
C
call MPI_Start(requests(1), ierr)
C
flag = .FALSE.
do while (.not. flag)
call MPI_Testany(1, requests(1), index, flag,
. statuses(1,1), ierr)
end do
call msg_check( recv_buf, prev, tag, count, statuses(1,1),
. TEST_SIZE, 'testany', errs )
do i = 1,count
send_buf(i) = recv_buf(i)
end do
C
call MPI_Start(requests(2), ierr)
call MPI_Wait(requests(2), status, ierr)
C
call MPI_Request_free(requests(2), ierr)
C
end if
C
call dummyRef( send_buf, count, ierr )
call MPI_Request_free(requests(1), ierr)
C
end
C
subroutine test_pair_sendrecv( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count
integer TEST_SIZE
parameter (TEST_SIZE=2000)
integer status(MPI_STATUS_SIZE)
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' Sendrecv'
endif
C
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
tag = 4123
count = TEST_SIZE / 5
call clear_test_data(recv_buf,TEST_SIZE)
if (rank .eq. 0) then
call init_test_data(send_buf,TEST_SIZE)
call MPI_Sendrecv(send_buf, count, MPI_REAL, next, tag,
. recv_buf, count, MPI_REAL, next, tag,
. comm, status, ierr)
call msg_check( recv_buf, next, tag, count, status, TEST_SIZE,
. 'sendrecv', errs )
else if (prev .eq. 0) then
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. status, ierr)
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'recv/send', errs )
call MPI_Send(recv_buf, count, MPI_REAL, prev, tag,
. comm, ierr)
end if
C
end
C
subroutine test_pair_sendrecvrepl( comm, errs )
implicit none
include 'mpif.h'
integer comm, errs
integer rank, size, ierr, next, prev, tag, count, i
integer TEST_SIZE
parameter (TEST_SIZE=2000)
integer status(MPI_STATUS_SIZE)
real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
logical verbose
common /flags/ verbose
C
if (verbose) then
print *, ' Sendrecv replace'
endif
C
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
next = rank + 1
if (next .ge. size) next = 0
C
prev = rank - 1
if (prev .lt. 0) prev = size - 1
C
tag = 4456
count = TEST_SIZE / 3
if (rank .eq. 0) then
C
call init_test_data(recv_buf, TEST_SIZE)
C
do 11 i = count+1,TEST_SIZE
recv_buf(i) = 0.0
11 continue
C
call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL,
. next, tag, next, tag,
. comm, status, ierr)
call msg_check( recv_buf, next, tag, count, status, TEST_SIZE,
. 'sendrecvreplace', errs )
else if (prev .eq. 0) then
call clear_test_data(recv_buf,TEST_SIZE)
call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
. MPI_ANY_SOURCE, MPI_ANY_TAG, comm,
. status, ierr)
call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
. 'recv/send for replace', errs )
call MPI_Send(recv_buf, count, MPI_REAL, prev, tag,
. comm, ierr)
end if
C
end
C
c------------------------------------------------------------------------------
c
c Check for correct source, tag, count, and data in test message.
c
c------------------------------------------------------------------------------
subroutine msg_check( recv_buf, source, tag, count, status, n,
* name, errs )
implicit none
include 'mpif.h'
integer n, errs
real recv_buf(n)
integer source, tag, count, rank, status(MPI_STATUS_SIZE)
character*(*) name
logical foundError
integer ierr, recv_src, recv_tag, recv_count
foundError = .false.
recv_src = status(MPI_SOURCE)
recv_tag = status(MPI_TAG)
call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
call MPI_Get_count(status, MPI_REAL, recv_count, ierr)
if (recv_src .ne. source) then
print *, '[', rank, '] Unexpected source:', recv_src,
* ' in ', name
errs = errs + 1
foundError = .true.
end if
if (recv_tag .ne. tag) then
print *, '[', rank, '] Unexpected tag:', recv_tag, ' in ', name
errs = errs + 1
foundError = .true.
end if
if (recv_count .ne. count) then
print *, '[', rank, '] Unexpected count:', recv_count,
* ' in ', name
errs = errs + 1
foundError = .true.
end if
call verify_test_data(recv_buf, count, n, name, errs )
end
c------------------------------------------------------------------------------
c
c Check that requests have been set to null
c
c------------------------------------------------------------------------------
subroutine rq_check( requests, n, msg )
include 'mpif.h'
integer n, requests(n)
character*(*) msg
integer i
c
do 10 i=1, n
if (requests(i) .ne. MPI_REQUEST_NULL) then
print *, 'Nonnull request in ', msg
endif
10 continue
c
end
c------------------------------------------------------------------------------
c
c Initialize test data buffer with integral sequence.
c
c------------------------------------------------------------------------------
subroutine init_test_data(buf,n)
integer n
real buf(n)
integer i
do 10 i = 1, n
buf(i) = REAL(i)
10 continue
end
c------------------------------------------------------------------------------
c
c Clear test data buffer
c
c------------------------------------------------------------------------------
subroutine clear_test_data(buf, n)
integer n
real buf(n)
integer i
do 10 i = 1, n
buf(i) = 0.
10 continue
end
c------------------------------------------------------------------------------
c
c Verify test data buffer
c
c------------------------------------------------------------------------------
subroutine verify_test_data( buf, count, n, name, errs )
implicit none
include 'mpif.h'
integer n, errs
real buf(n)
character *(*) name
integer count, ierr, i
C
do 10 i = 1, count
if (buf(i) .ne. REAL(i)) then
print 100, buf(i), i, count, name
errs = errs + 1
endif
10 continue
C
do 20 i = count + 1, n
if (buf(i) .ne. 0.) then
print 100, buf(i), i, n, name
errs = errs + 1
endif
20 continue
C
100 format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)
C
end
C
C This routine is used to prevent the compiler from deallocating the
C array "a", which may happen in some of the tests (see the text in
C the MPI standard about why this may be a problem in valid Fortran
C codes). Without this, for example, tests fail with the Cray ftn
C compiler.
C
subroutine dummyRef( a, n, ie )
integer n, ie
real a(n)
C This condition will never be true, but the compile won't know that
if (ie .eq. -1) then
print *, a(n)
endif
return
end