+++ /dev/null
-c
-c This program was inspired by a bug report from
-c fsset@corelli.lerc.nasa.gov (Scott Townsend)
-c The original version of this program was submitted by email to
-c mpi-bugs and is in the directory mpich/bugs/ssend (not distributed
-c with the distribution). This program was modified by William
-c Gropp (to correct a few errors and make more consistent with the
-c structure of the test programs in the examples/test/pt2pt directory.
-
-c A C version of this program is in allpairc.c
-c
- program allpair
- include 'mpif.h'
- integer ierr
-
- call MPI_Init(ierr)
-
- call test_pair
-
- call MPI_Finalize(ierr)
-
- end
-
-c------------------------------------------------------------------------------
-c
-c Simple pair communication exercises.
-c
-c------------------------------------------------------------------------------
- subroutine test_pair
- include 'mpif.h'
- integer TEST_SIZE
- parameter (TEST_SIZE=2000)
-
- integer ierr, prev, next, count, tag, index, i, outcount,
- . requests(2), indices(2), rank, size,
- . status(MPI_STATUS_SIZE), statuses(MPI_STATUS_SIZE,2)
- integer dupcom
- logical flag
- real send_buf( TEST_SIZE ), recv_buf ( TEST_SIZE )
-
- call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
- call MPI_Comm_size( MPI_COMM_WORLD, size, ierr )
- if (size .ne. 2) then
- print *, 'Allpair test requires exactly 2 processes'
- call MPI_Abort( MPI_COMM_WORLD, 1, ierr )
- endif
-C print *, ' about to do dup'
- call MPI_Comm_dup( MPI_COMM_WORLD, dupcom, ierr )
-C print *, ' did dup'
- next = rank + 1
- if (next .ge. size) next = 0
-
- prev = rank - 1
- if (prev .lt. 0) prev = size - 1
-c
-c Normal sends
-c
- if (rank .eq. 0) then
- print *, ' Send'
- end if
-
- tag = 1123
- 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_Send(send_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, ierr)
-
- call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'send and recv' )
- else
- call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'send and recv' )
-
- call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, ierr)
- end if
-c
-c Ready sends. Note that we must insure that the receive is posted
-c before the rsend; this requires using Irecv.
-c
- if (rank .eq. 0) then
- print *, ' Rsend'
- end if
-
- tag = 1456
- count = TEST_SIZE / 3
-
- call clear_test_data(recv_buf,TEST_SIZE)
-
- if (rank .eq. 0) then
-
- call init_test_data(send_buf,TEST_SIZE)
-
- call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
- . MPI_COMM_WORLD, status, ierr )
-
- call MPI_Rsend(send_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, ierr)
-
- call MPI_Probe(MPI_ANY_SOURCE, tag,
- . MPI_COMM_WORLD, status, ierr)
-
- if (status(MPI_SOURCE) .ne. prev) then
- print *, 'Incorrect source, expected', prev,
- . ', got', status(MPI_SOURCE)
- end if
-
- if (status(MPI_TAG) .ne. tag) then
- print *, 'Incorrect tag, expected', tag,
- . ', got', status(MPI_TAG)
- end if
-
- call MPI_Get_count(status, MPI_REAL, i, ierr)
-
- if (i .ne. count) then
- print *, 'Incorrect count, expected', count,
- . ', got', i
- end if
-
- call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'rsend and recv' )
-
- else
-
- call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . requests(1), ierr)
- call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
- . MPI_COMM_WORLD, ierr )
- call MPI_Wait( requests(1), status, ierr )
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'rsend and recv' )
-
- call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, ierr)
- end if
-c
-c Synchronous sends
-c
- if (rank .eq. 0) then
- print *, ' Ssend'
- end if
-
- tag = 1789
- count = TEST_SIZE / 3
-
- call clear_test_data(recv_buf,TEST_SIZE)
-
- if (rank .eq. 0) then
-
- call init_test_data(send_buf,TEST_SIZE)
-
- call MPI_Iprobe(MPI_ANY_SOURCE, tag,
- . MPI_COMM_WORLD, flag, status, ierr)
-
- if (flag) then
- print *, 'Iprobe succeeded! source', status(MPI_SOURCE),
- . ', tag', status(MPI_TAG)
- end if
-
- call MPI_Ssend(send_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, ierr)
-
- do while (.not. flag)
- call MPI_Iprobe(MPI_ANY_SOURCE, tag,
- . MPI_COMM_WORLD, flag, status, ierr)
- end do
-
- if (status(MPI_SOURCE) .ne. prev) then
- print *, 'Incorrect source, expected', prev,
- . ', got', status(MPI_SOURCE)
- end if
-
- if (status(MPI_TAG) .ne. tag) then
- print *, 'Incorrect tag, expected', tag,
- . ', got', status(MPI_TAG)
- end if
-
- call MPI_Get_count(status, MPI_REAL, i, ierr)
-
- if (i .ne. count) then
- print *, 'Incorrect count, expected', count,
- . ', got', i
- end if
-
- call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status,
- $ TEST_SIZE, 'ssend and recv' )
-
- else
-
- call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'ssend and recv' )
-
- call MPI_Ssend(recv_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, ierr)
- end if
-c
-c Nonblocking normal sends
-c
- if (rank .eq. 0) then
- print *, ' Isend'
- end if
-
- tag = 2123
- count = TEST_SIZE / 5
-
- call clear_test_data(recv_buf,TEST_SIZE)
-
- if (rank .eq. 0) then
-
- call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . requests(1), ierr)
-
- call init_test_data(send_buf,TEST_SIZE)
-
- call MPI_Isend(send_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, requests(2), ierr)
-
- call MPI_Waitall(2, requests, statuses, ierr)
-
- call rq_check( requests, 2, 'isend and irecv' )
-
- call msg_check( recv_buf, prev, tag, count, statuses(1,1),
- $ TEST_SIZE, 'isend and irecv' )
-
- else
-
- call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'isend and irecv' )
-
- call MPI_Isend(recv_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, requests(1), ierr)
-
- call MPI_Wait(requests(1), status, ierr)
-
- call rq_check( requests(1), 1, 'isend and irecv' )
-
- end if
-c
-c Nonblocking ready sends
-c
- if (rank .eq. 0) then
- print *, ' Irsend'
- end if
-
- tag = 2456
- count = TEST_SIZE / 3
-
- call clear_test_data(recv_buf,TEST_SIZE)
-
-c
-c This test needs work for comm_size > 2
-c
- if (rank .eq. 0) then
-
- call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . requests(1), ierr)
-
- call init_test_data(send_buf,TEST_SIZE)
-
- call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
- . MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
- . dupcom, status, ierr )
-
- call MPI_Irsend(send_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, requests(2), ierr)
-
- index = -1
- do while (index .ne. 1)
- call MPI_Waitany(2, requests, index, statuses, ierr)
- end do
-
- call rq_check( requests(1), 1, 'irsend and irecv' )
-
- call msg_check( recv_buf, prev, tag, count, statuses,
- $ TEST_SIZE, 'irsend and irecv' )
-
- else
-
- call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . requests(1), ierr)
-
- call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
- . MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
- . dupcom, status, ierr )
-
- flag = .FALSE.
- do while (.not. flag)
- call MPI_Test(requests(1), flag, status, ierr)
- end do
-
- call rq_check( requests, 1, 'irsend and irecv (test)' )
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'irsend and irecv' )
-
- call MPI_Irsend(recv_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, requests(1), ierr)
-
- call MPI_Waitall(1, requests, statuses, ierr)
-
- call rq_check( requests, 1, 'irsend and irecv' )
-
- end if
-
-c
-c Nonblocking synchronous sends
-c
- if (rank .eq. 0) then
- print *, ' Issend'
- end if
-
- tag = 2789
- count = TEST_SIZE / 3
-
- call clear_test_data(recv_buf,TEST_SIZE)
-
- if (rank .eq. 0) then
-
- call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . requests(1), ierr)
-
- call init_test_data(send_buf,TEST_SIZE)
-
- call MPI_Issend(send_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, requests(2), ierr)
-
- flag = .FALSE.
- do while (.not. flag)
- call MPI_Testall(2, requests, flag, statuses, ierr)
-C print *, 'flag = ', flag
- end do
-
- call rq_check( requests, 2, 'issend and irecv (testall)' )
-
- call msg_check( recv_buf, prev, tag, count, statuses(1,1),
- $ TEST_SIZE, 'issend and recv (testall)' )
-
- else
-
- call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'issend and recv' )
-
- call MPI_Issend(recv_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, requests(1), ierr)
-
- flag = .FALSE.
- do while (.not. flag)
- call MPI_Testany(1, requests(1), index, flag,
- . statuses(1,1), ierr)
-c print *, 'flag = ', flag
- end do
-
- call rq_check( requests, 1, 'issend and recv (testany)' )
-
- end if
-c
-c Persistent normal sends
-c
- if (rank .eq. 0) then
- print *, ' Send_init'
- end if
-
- tag = 3123
- count = TEST_SIZE / 5
-
- call clear_test_data(recv_buf,TEST_SIZE)
-
- call MPI_Send_init(send_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, requests(1), ierr)
-
- call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . requests(2), ierr)
-
- if (rank .eq. 0) then
-
- call init_test_data(send_buf,TEST_SIZE)
-
- call MPI_Startall(2, requests, ierr)
- call MPI_Waitall(2, requests, statuses, ierr)
-
- call msg_check( recv_buf, prev, tag, count, statuses(1,2),
- $ TEST_SIZE, 'persistent send/recv' )
-
- else
-
- call MPI_Start(requests(2), ierr)
- call MPI_Wait(requests(2), status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- * 'persistent send/recv')
-
- do i = 1,count
- send_buf(i) = recv_buf(i)
- end do
-
- call MPI_Start(requests(1), ierr)
- call MPI_Wait(requests(1), status, ierr)
-
- end if
-
- call MPI_Request_free(requests(1), ierr)
- call MPI_Request_free(requests(2), ierr)
-c
-c Persistent ready sends
-c
- if (rank .eq. 0) then
- print *, ' Rsend_init'
- end if
-
- tag = 3456
- count = TEST_SIZE / 3
-
- call clear_test_data(recv_buf,TEST_SIZE)
-
- call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, requests(1), ierr)
-
- call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . requests(2), ierr)
-
- if (rank .eq. 0) then
-
- call init_test_data(send_buf,TEST_SIZE)
-
- call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
- . MPI_COMM_WORLD, status, ierr )
-
- call MPI_Startall(2, requests, ierr)
-
- index = -1
-
- 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, prev, tag, count,
- $ statuses(1,i), TEST_SIZE, 'waitsome' )
- index = 2
- end if
- end do
- end do
-
- else
-
- call MPI_Start(requests(2), ierr)
-
- call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
- . MPI_COMM_WORLD, ierr )
-
- 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' )
-
- do i = 1,count
- send_buf(i) = recv_buf(i)
- end do
-
- call MPI_Start(requests(1), ierr)
- call MPI_Wait(requests(1), status, ierr)
-
- end if
-
- call MPI_Request_free(requests(1), ierr)
- call MPI_Request_free(requests(2), ierr)
-c
-c Persistent synchronous sends
-c
- if (rank .eq. 0) then
- print *, ' Ssend_init'
- end if
-
- tag = 3789
- count = TEST_SIZE / 3
-
- call clear_test_data(recv_buf,TEST_SIZE)
-
- call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, requests(2), ierr)
-
- call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . requests(1), ierr)
-
- if (rank .eq. 0) then
-
- call init_test_data(send_buf,TEST_SIZE)
-
- call MPI_Startall(2, requests, ierr)
-
- 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, prev, tag, count,
- $ statuses(1,i), TEST_SIZE, 'testsome' )
- index = 1
- end if
- end do
- end do
- else
-
- call MPI_Start(requests(1), ierr)
-
- 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' )
-
- do i = 1,count
- send_buf(i) = recv_buf(i)
- end do
-
- call MPI_Start(requests(2), ierr)
- call MPI_Wait(requests(2), status, ierr)
-
- end if
-
- call MPI_Request_free(requests(1), ierr)
- call MPI_Request_free(requests(2), ierr)
-c
-c Send/receive.
-c
- if (rank .eq. 0) then
- print *, ' Sendrecv'
- end if
-
- 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, prev, tag,
- . MPI_COMM_WORLD, status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'sendrecv' )
-
- else
-
- call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'recv/send' )
-
- call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, ierr)
- end if
-c
-c Send/receive replace.
-c
- if (rank .eq. 0) then
- print *, ' Sendrecv_replace'
- end if
-
- tag = 4456
- count = TEST_SIZE / 3
-
- if (rank .eq. 0) then
-
- call init_test_data(recv_buf, TEST_SIZE)
-
- do 11 i = count+1,TEST_SIZE
- recv_buf(i) = 0.0
- 11 continue
-
- call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL,
- . next, tag, prev, tag,
- . MPI_COMM_WORLD, status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'sendrecvreplace' )
-
- else
-
- call clear_test_data(recv_buf,TEST_SIZE)
-
- call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
- . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
- . status, ierr)
-
- call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
- . 'recv/send for replace' )
-
- call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
- . MPI_COMM_WORLD, ierr)
- end if
-
- call MPI_Comm_free( dupcom, ierr )
- return
- end
-
-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 )
- include 'mpif.h'
- integer n
- real recv_buf(n)
- integer source, tag, count, rank, status(MPI_STATUS_SIZE)
- character*(*) name
-
- integer ierr, recv_src, recv_tag, recv_count
-
- 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
- call MPI_Abort(MPI_COMM_WORLD, 101, ierr)
- end if
-
- if (recv_tag .ne. tag) then
- print *, '[', rank, '] Unexpected tag:', recv_tag, ' in ', name
- call MPI_Abort(MPI_COMM_WORLD, 102, ierr)
- end if
-
- if (recv_count .ne. count) then
- print *, '[', rank, '] Unexpected count:', recv_count,
- * ' in ', name
- call MPI_Abort(MPI_COMM_WORLD, 103, ierr)
- end if
-
- call verify_test_data(recv_buf, count, n, name )
-
- 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)
- include 'mpif.h'
- integer n
- real buf(n)
- character *(*) name
-
- integer count, ierr, i
-
- do 10 i = 1, count
- if (buf(i) .ne. REAL(i)) then
- print 100, buf(i), i, count, name
- call MPI_Abort(MPI_COMM_WORLD, 108, ierr)
- endif
- 10 continue
-
- do 20 i = count + 1, n
- if (buf(i) .ne. 0.) then
- print 100, buf(i), i, n, name
- call MPI_Abort(MPI_COMM_WORLD, 109, ierr)
- endif
- 20 continue
-
-100 format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)
-
- end
