X-Git-Url: http://info.iut-bm.univ-fcomte.fr/pub/gitweb/simgrid.git/blobdiff_plain/3f31053637ef02fcd96e3819683103686ce11992..9deda161a84a426d0ea75ec4bd9b8cdc3a4b28fb:/teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f diff --git a/teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f b/teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f new file mode 100644 index 0000000000..750c56816c --- /dev/null +++ b/teshsuite/smpi/mpich3-test/f77/pt2pt/allpairf.f @@ -0,0 +1,1029 @@ +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 +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