1 ! This file created from test/mpi/f77/pt2pt/allpairf.f with f77tof90
2 ! -*- Mode: Fortran; -*-
4 ! (C) 2012 by Argonne National Laboratory.
5 ! See COPYRIGHT in top-level directory.
7 ! This program is based on the allpair.f test from the MPICH-1 test
8 ! (test/pt2pt/allpair.f), which in turn was inspired by a bug report from
9 ! fsset@corelli.lerc.nasa.gov (Scott Townsend)
13 integer ierr, errs, comm
14 logical mtestGetIntraComm
16 common /flags/ verbose
21 call MTest_Init( ierr )
23 do while ( mtestGetIntraComm( comm, 2, .false. ) )
24 call test_pair_send( comm, errs )
25 call test_pair_ssend( comm, errs )
26 !call test_pair_rsend( comm, errs )
27 call test_pair_isend( comm, errs )
28 !call test_pair_irsend( comm, errs )
29 call test_pair_issend( comm, errs )
30 call test_pair_psend( comm, errs )
31 !call test_pair_prsend( comm, errs )
32 call test_pair_pssend( comm, errs )
33 call test_pair_sendrecv( comm, errs )
34 call test_pair_sendrecvrepl( comm, errs )
35 call mtestFreeComm( comm )
38 call MTest_Finalize( errs )
39 call MPI_Finalize(ierr)
43 subroutine test_pair_send( comm, errs )
46 integer rank, size, ierr, next, prev, tag, count
48 parameter (TEST_SIZE=2000)
49 integer status(MPI_STATUS_SIZE)
50 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
52 common /flags/ verbose
55 print *, ' Send and recv'
58 call mpi_comm_rank( comm, rank, ierr )
59 call mpi_comm_size( comm, size, ierr )
61 if (next .ge. size) next = 0
64 if (prev .lt. 0) prev = size - 1
69 call clear_test_data(recv_buf,TEST_SIZE)
73 call init_test_data(send_buf,TEST_SIZE)
75 call MPI_Send(send_buf, count, MPI_REAL, next, tag, &
78 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
79 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
81 call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
82 & 'send and recv', errs )
83 else if (prev .eq. 0) then
84 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
85 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
87 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
88 & 'send and recv', errs )
90 call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr)
95 subroutine test_pair_rsend( comm, errs )
98 integer rank, size, ierr, next, prev, tag, count, i
100 parameter (TEST_SIZE=2000)
101 integer status(MPI_STATUS_SIZE), requests(1)
102 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
104 common /flags/ verbose
107 print *, ' Rsend and recv'
111 call mpi_comm_rank( comm, rank, ierr )
112 call mpi_comm_size( comm, size, ierr )
114 if (next .ge. size) next = 0
117 if (prev .lt. 0) prev = size - 1
120 count = TEST_SIZE / 3
122 call clear_test_data(recv_buf,TEST_SIZE)
124 if (rank .eq. 0) then
126 call init_test_data(send_buf,TEST_SIZE)
128 call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, &
129 & comm, status, ierr )
131 call MPI_Rsend(send_buf, count, MPI_REAL, next, tag, &
134 call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr)
136 if (status(MPI_SOURCE) .ne. next) then
137 print *, 'Rsend: Incorrect source, expected', next, &
138 & ', got', status(MPI_SOURCE)
142 if (status(MPI_TAG) .ne. tag) then
143 print *, 'Rsend: Incorrect tag, expected', tag, &
144 & ', got', status(MPI_TAG)
148 call MPI_Get_count(status, MPI_REAL, i, ierr)
150 if (i .ne. count) then
151 print *, 'Rsend: Incorrect count, expected', count, &
156 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
157 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
160 call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
161 & 'rsend and recv', errs )
163 else if (prev .eq. 0) then
165 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
166 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
168 call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag, &
170 call MPI_Wait( requests(1), status, ierr )
171 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
172 & 'rsend and recv', errs )
174 call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
180 subroutine test_pair_ssend( comm, errs )
183 integer rank, size, ierr, next, prev, tag, count, i
185 parameter (TEST_SIZE=2000)
186 integer status(MPI_STATUS_SIZE)
188 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
190 common /flags/ verbose
193 print *, ' Ssend and recv'
197 call mpi_comm_rank( comm, rank, ierr )
198 call mpi_comm_size( comm, size, ierr )
200 if (next .ge. size) next = 0
203 if (prev .lt. 0) prev = size - 1
206 count = TEST_SIZE / 3
208 call clear_test_data(recv_buf,TEST_SIZE)
210 if (rank .eq. 0) then
212 call init_test_data(send_buf,TEST_SIZE)
214 call MPI_Iprobe(MPI_ANY_SOURCE, tag, &
215 & comm, flag, status, ierr)
218 print *, 'Ssend: Iprobe succeeded! source', &
219 & status(MPI_SOURCE), &
220 & ', tag', status(MPI_TAG)
224 call MPI_Ssend(send_buf, count, MPI_REAL, next, tag, &
227 do while (.not. flag)
228 call MPI_Iprobe(MPI_ANY_SOURCE, tag, &
229 & comm, flag, status, ierr)
232 if (status(MPI_SOURCE) .ne. next) then
233 print *, 'Ssend: Incorrect source, expected', next, &
234 & ', got', status(MPI_SOURCE)
238 if (status(MPI_TAG) .ne. tag) then
239 print *, 'Ssend: Incorrect tag, expected', tag, &
240 & ', got', status(MPI_TAG)
244 call MPI_Get_count(status, MPI_REAL, i, ierr)
246 if (i .ne. count) then
247 print *, 'Ssend: Incorrect count, expected', count, &
252 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
253 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
256 call msg_check( recv_buf, next, tag, count, status, &
257 & TEST_SIZE, 'ssend and recv', errs )
259 else if (prev .eq. 0) then
261 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
262 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
265 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
266 & 'ssend and recv', errs )
268 call MPI_Ssend(recv_buf, count, MPI_REAL, prev, tag, &
274 subroutine test_pair_isend( comm, errs )
277 integer rank, size, ierr, next, prev, tag, count
279 parameter (TEST_SIZE=2000)
280 integer status(MPI_STATUS_SIZE), requests(2)
281 integer statuses(MPI_STATUS_SIZE,2)
282 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
284 common /flags/ verbose
287 print *, ' isend and irecv'
291 call mpi_comm_rank( comm, rank, ierr )
292 call mpi_comm_size( comm, size, ierr )
294 if (next .ge. size) next = 0
297 if (prev .lt. 0) prev = size - 1
300 count = TEST_SIZE / 5
302 call clear_test_data(recv_buf,TEST_SIZE)
304 if (rank .eq. 0) then
306 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
307 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
310 call init_test_data(send_buf,TEST_SIZE)
312 call MPI_Isend(send_buf, count, MPI_REAL, next, tag, &
313 & comm, requests(2), ierr)
315 call MPI_Waitall(2, requests, statuses, ierr)
317 call rq_check( requests, 2, 'isend and irecv' )
319 call msg_check( recv_buf, next, tag, count, statuses(1,1), &
320 & TEST_SIZE, 'isend and irecv', errs )
322 else if (prev .eq. 0) then
324 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
325 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
328 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
329 & 'isend and irecv', errs )
331 call MPI_Isend(recv_buf, count, MPI_REAL, prev, tag, &
332 & comm, requests(1), ierr)
334 call MPI_Wait(requests(1), status, ierr)
336 call rq_check( requests(1), 1, 'isend and irecv' )
342 subroutine test_pair_irsend( comm, errs )
345 integer rank, size, ierr, next, prev, tag, count, index, i
348 parameter (TEST_SIZE=2000)
349 integer status(MPI_STATUS_SIZE), requests(2)
350 integer statuses(MPI_STATUS_SIZE,2)
352 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
354 common /flags/ verbose
357 print *, ' Irsend and irecv'
360 call mpi_comm_rank( comm, rank, ierr )
361 call mpi_comm_size( comm, size, ierr )
363 if (next .ge. size) next = 0
366 if (prev .lt. 0) prev = size - 1
368 call mpi_comm_dup( comm, dupcom, ierr )
371 count = TEST_SIZE / 3
373 call clear_test_data(recv_buf,TEST_SIZE)
375 if (rank .eq. 0) then
377 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
378 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
381 call init_test_data(send_buf,TEST_SIZE)
383 call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0, &
384 & MPI_BOTTOM, 0, MPI_INTEGER, next, 0, &
385 & dupcom, status, ierr )
387 call MPI_Irsend(send_buf, count, MPI_REAL, next, tag, &
388 & comm, requests(2), ierr)
391 do while (index .ne. 1)
392 call MPI_Waitany(2, requests, index, statuses, ierr)
395 call rq_check( requests(1), 1, 'irsend and irecv' )
397 call msg_check( recv_buf, next, tag, count, statuses, &
398 & TEST_SIZE, 'irsend and irecv', errs )
400 else if (prev .eq. 0) then
402 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
403 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
406 call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, prev, 0, &
407 & MPI_BOTTOM, 0, MPI_INTEGER, prev, 0, &
408 & dupcom, status, ierr )
411 do while (.not. flag)
412 call MPI_Test(requests(1), flag, status, ierr)
415 call rq_check( requests, 1, 'irsend and irecv (test)' )
417 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
418 & 'irsend and irecv', errs )
420 call MPI_Irsend(recv_buf, count, MPI_REAL, prev, tag, &
421 & comm, requests(1), ierr)
423 call MPI_Waitall(1, requests, statuses, ierr)
425 call rq_check( requests, 1, 'irsend and irecv' )
429 call mpi_comm_free( dupcom, ierr )
433 subroutine test_pair_issend( comm, errs )
436 integer rank, size, ierr, next, prev, tag, count, index
438 parameter (TEST_SIZE=2000)
439 integer status(MPI_STATUS_SIZE), requests(2)
440 integer statuses(MPI_STATUS_SIZE,2)
442 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
444 common /flags/ verbose
447 print *, ' issend and irecv (testall)'
451 call mpi_comm_rank( comm, rank, ierr )
452 call mpi_comm_size( comm, size, ierr )
454 if (next .ge. size) next = 0
457 if (prev .lt. 0) prev = size - 1
460 count = TEST_SIZE / 3
462 call clear_test_data(recv_buf,TEST_SIZE)
464 if (rank .eq. 0) then
466 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
467 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
470 call init_test_data(send_buf,TEST_SIZE)
472 call MPI_Issend(send_buf, count, MPI_REAL, next, tag, &
473 & comm, requests(2), ierr)
476 do while (.not. flag)
477 call MPI_Testall(2, requests, flag, statuses, ierr)
480 call rq_check( requests, 2, 'issend and irecv (testall)' )
482 call msg_check( recv_buf, next, tag, count, statuses(1,1), &
483 & TEST_SIZE, 'issend and recv (testall)', errs )
485 else if (prev .eq. 0) then
487 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
488 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
491 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
492 & 'issend and recv', errs )
494 call MPI_Issend(recv_buf, count, MPI_REAL, prev, tag, &
495 & comm, requests(1), ierr)
498 do while (.not. flag)
499 call MPI_Testany(1, requests(1), index, flag, &
500 & statuses(1,1), ierr)
503 call rq_check( requests, 1, 'issend and recv (testany)' )
509 subroutine test_pair_psend( comm, errs )
512 integer rank, size, ierr, next, prev, tag, count, i
514 parameter (TEST_SIZE=2000)
515 integer status(MPI_STATUS_SIZE)
516 integer statuses(MPI_STATUS_SIZE,2), requests(2)
517 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
519 common /flags/ verbose
522 print *, ' Persistent send and recv'
525 call mpi_comm_rank( comm, rank, ierr )
526 call mpi_comm_size( comm, size, ierr )
528 if (next .ge. size) next = 0
531 if (prev .lt. 0) prev = size - 1
534 count = TEST_SIZE / 5
536 call clear_test_data(recv_buf,TEST_SIZE)
537 call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, &
538 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
541 if (rank .eq. 0) then
543 call init_test_data(send_buf,TEST_SIZE)
545 call MPI_Send_init(send_buf, count, MPI_REAL, next, tag, &
546 & comm, requests(1), ierr)
548 call MPI_Startall(2, requests, ierr)
549 call MPI_Waitall(2, requests, statuses, ierr)
551 call msg_check( recv_buf, next, tag, count, statuses(1,2), &
552 & TEST_SIZE, 'persistent send/recv', errs )
554 call MPI_Request_free(requests(1), ierr)
556 else if (prev .eq. 0) then
558 call MPI_Send_init(send_buf, count, MPI_REAL, prev, tag, &
559 & comm, requests(1), ierr)
560 call MPI_Start(requests(2), ierr)
561 call MPI_Wait(requests(2), status, ierr)
563 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
564 & 'persistent send/recv', errs )
567 send_buf(i) = recv_buf(i)
570 call MPI_Start(requests(1), ierr)
571 call MPI_Wait(requests(1), status, ierr)
573 call MPI_Request_free(requests(1), ierr)
576 call dummyRef( send_buf, count, ierr )
577 call MPI_Request_free(requests(2), ierr)
581 subroutine test_pair_prsend( comm, errs )
584 integer rank, size, ierr, next, prev, tag, count, index, i
585 integer outcount, indices(2)
587 parameter (TEST_SIZE=2000)
588 integer statuses(MPI_STATUS_SIZE,2), requests(2)
589 integer status(MPI_STATUS_SIZE)
591 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
593 common /flags/ verbose
596 print *, ' Persistent Rsend and recv'
599 call mpi_comm_rank( comm, rank, ierr )
600 call mpi_comm_size( comm, size, ierr )
602 if (next .ge. size) next = 0
605 if (prev .lt. 0) prev = size - 1
608 count = TEST_SIZE / 3
610 call clear_test_data(recv_buf,TEST_SIZE)
612 call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, &
613 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
616 if (rank .eq. 0) then
618 call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag, &
619 & comm, requests(1), ierr)
621 call init_test_data(send_buf,TEST_SIZE)
623 call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, &
624 & comm, status, ierr )
626 call MPI_Startall(2, requests, ierr)
630 do while (index .ne. 2)
631 call MPI_Waitsome(2, requests, outcount, &
632 & indices, statuses, ierr)
634 if (indices(i) .eq. 2) then
635 call msg_check( recv_buf, next, tag, count, &
636 & statuses(1,i), TEST_SIZE, 'waitsome', errs )
642 call MPI_Request_free(requests(1), ierr)
643 else if (prev .eq. 0) then
645 call MPI_Rsend_init(send_buf, count, MPI_REAL, prev, tag, &
646 & comm, requests(1), ierr)
648 call MPI_Start(requests(2), ierr)
650 call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag, &
654 do while (.not. flag)
655 call MPI_Test(requests(2), flag, status, ierr)
657 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
661 send_buf(i) = recv_buf(i)
664 call MPI_Start(requests(1), ierr)
665 call MPI_Wait(requests(1), status, ierr)
667 call MPI_Request_free(requests(1), ierr)
670 call dummyRef( send_buf, count, ierr )
671 call MPI_Request_free(requests(2), ierr)
675 subroutine test_pair_pssend( comm, errs )
678 integer rank, size, ierr, next, prev, tag, count, index, i
679 integer outcount, indices(2)
681 parameter (TEST_SIZE=2000)
682 integer statuses(MPI_STATUS_SIZE,2), requests(2)
683 integer status(MPI_STATUS_SIZE)
685 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
687 common /flags/ verbose
690 print *, ' Persistent Ssend and recv'
693 call mpi_comm_rank( comm, rank, ierr )
694 call mpi_comm_size( comm, size, ierr )
696 if (next .ge. size) next = 0
699 if (prev .lt. 0) prev = size - 1
702 count = TEST_SIZE / 3
704 call clear_test_data(recv_buf,TEST_SIZE)
706 call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, &
707 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
710 if (rank .eq. 0) then
712 call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag, &
713 & comm, requests(2), ierr)
715 call init_test_data(send_buf,TEST_SIZE)
717 call MPI_Startall(2, requests, ierr)
720 do while (index .ne. 1)
721 call MPI_Testsome(2, requests, outcount, &
722 & indices, statuses, ierr)
724 if (indices(i) .eq. 1) then
725 call msg_check( recv_buf, next, tag, count, &
726 & statuses(1,i), TEST_SIZE, 'testsome', errs )
732 call MPI_Request_free(requests(2), ierr)
734 else if (prev .eq. 0) then
736 call MPI_Ssend_init(send_buf, count, MPI_REAL, prev, tag, &
737 & comm, requests(2), ierr)
739 call MPI_Start(requests(1), ierr)
742 do while (.not. flag)
743 call MPI_Testany(1, requests(1), index, flag, &
744 & statuses(1,1), ierr)
746 call msg_check( recv_buf, prev, tag, count, statuses(1,1), &
747 & TEST_SIZE, 'testany', errs )
750 send_buf(i) = recv_buf(i)
753 call MPI_Start(requests(2), ierr)
754 call MPI_Wait(requests(2), status, ierr)
756 call MPI_Request_free(requests(2), ierr)
760 call dummyRef( send_buf, count, ierr )
761 call MPI_Request_free(requests(1), ierr)
765 subroutine test_pair_sendrecv( comm, errs )
768 integer rank, size, ierr, next, prev, tag, count
770 parameter (TEST_SIZE=2000)
771 integer status(MPI_STATUS_SIZE)
772 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
774 common /flags/ verbose
781 call mpi_comm_rank( comm, rank, ierr )
782 call mpi_comm_size( comm, size, ierr )
784 if (next .ge. size) next = 0
787 if (prev .lt. 0) prev = size - 1
790 count = TEST_SIZE / 5
792 call clear_test_data(recv_buf,TEST_SIZE)
794 if (rank .eq. 0) then
796 call init_test_data(send_buf,TEST_SIZE)
798 call MPI_Sendrecv(send_buf, count, MPI_REAL, next, tag, &
799 & recv_buf, count, MPI_REAL, next, tag, &
800 & comm, status, ierr)
802 call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
805 else if (prev .eq. 0) then
807 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
808 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
811 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
812 & 'recv/send', errs )
814 call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
820 subroutine test_pair_sendrecvrepl( comm, errs )
823 integer rank, size, ierr, next, prev, tag, count, i
825 parameter (TEST_SIZE=2000)
826 integer status(MPI_STATUS_SIZE)
827 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
829 common /flags/ verbose
832 print *, ' Sendrecv replace'
835 call mpi_comm_rank( comm, rank, ierr )
836 call mpi_comm_size( comm, size, ierr )
838 if (next .ge. size) next = 0
841 if (prev .lt. 0) prev = size - 1
844 count = TEST_SIZE / 3
846 if (rank .eq. 0) then
848 call init_test_data(recv_buf, TEST_SIZE)
850 do 11 i = count+1,TEST_SIZE
854 call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL, &
855 & next, tag, next, tag, &
856 & comm, status, ierr)
858 call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
859 & 'sendrecvreplace', errs )
861 else if (prev .eq. 0) then
863 call clear_test_data(recv_buf,TEST_SIZE)
865 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
866 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
869 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
870 & 'recv/send for replace', errs )
872 call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
878 !------------------------------------------------------------------------------
880 ! Check for correct source, tag, count, and data in test message.
882 !------------------------------------------------------------------------------
883 subroutine msg_check( recv_buf, source, tag, count, status, n, &
888 integer source, tag, count, rank, status(MPI_STATUS_SIZE)
892 integer ierr, recv_src, recv_tag, recv_count
895 recv_src = status(MPI_SOURCE)
896 recv_tag = status(MPI_TAG)
897 call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
898 call MPI_Get_count(status, MPI_REAL, recv_count, ierr)
900 if (recv_src .ne. source) then
901 print *, '[', rank, '] Unexpected source:', recv_src, &
907 if (recv_tag .ne. tag) then
908 print *, '[', rank, '] Unexpected tag:', recv_tag, ' in ', name
913 if (recv_count .ne. count) then
914 print *, '[', rank, '] Unexpected count:', recv_count, &
920 call verify_test_data(recv_buf, count, n, name, errs )
923 !------------------------------------------------------------------------------
925 ! Check that requests have been set to null
927 !------------------------------------------------------------------------------
928 subroutine rq_check( requests, n, msg )
930 integer n, requests(n)
935 if (requests(i) .ne. MPI_REQUEST_NULL) then
936 print *, 'Nonnull request in ', msg
941 !------------------------------------------------------------------------------
943 ! Initialize test data buffer with integral sequence.
945 !------------------------------------------------------------------------------
946 subroutine init_test_data(buf,n)
956 !------------------------------------------------------------------------------
958 ! Clear test data buffer
960 !------------------------------------------------------------------------------
961 subroutine clear_test_data(buf, n)
972 !------------------------------------------------------------------------------
974 ! Verify test data buffer
976 !------------------------------------------------------------------------------
977 subroutine verify_test_data( buf, count, n, name, errs )
982 integer count, ierr, i
985 if (buf(i) .ne. REAL(i)) then
986 print 100, buf(i), i, count, name
991 do 20 i = count + 1, n
992 if (buf(i) .ne. 0.) then
993 print 100, buf(i), i, n, name
998 100 format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)
1002 ! This routine is used to prevent the compiler from deallocating the
1003 ! array "a", which may happen in some of the tests (see the text in
1004 ! the MPI standard about why this may be a problem in valid Fortran
1005 ! codes). Without this, for example, tests fail with the Cray ftn
1008 subroutine dummyRef( a, n, ie )
1011 ! This condition will never be true, but the compile won't know that
1012 if (ie .eq. -1) then