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. ) )
25 call test_pair_send( comm, errs )
26 call test_pair_ssend( comm, errs )
27 !call test_pair_rsend( comm, errs )
28 call test_pair_isend( comm, errs )
29 !call test_pair_irsend( comm, errs )
30 call test_pair_issend( comm, errs )
31 call test_pair_psend( comm, errs )
32 !call test_pair_prsend( comm, errs )
33 !call test_pair_pssend( comm, errs )
34 call test_pair_sendrecv( comm, errs )
35 call test_pair_sendrecvrepl( comm, errs )
36 call mtestFreeComm( comm )
39 call MTest_Finalize( errs )
40 call MPI_Finalize(ierr)
44 subroutine test_pair_send( comm, errs )
47 integer rank, size, ierr, next, prev, tag, count
49 parameter (TEST_SIZE=2000)
50 integer status(MPI_STATUS_SIZE)
51 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
53 common /flags/ verbose
56 print *, ' Send and recv'
59 call mpi_comm_rank( comm, rank, ierr )
60 call mpi_comm_size( comm, size, ierr )
62 if (next .ge. size) next = 0
65 if (prev .lt. 0) prev = size - 1
70 call clear_test_data(recv_buf,TEST_SIZE)
74 call init_test_data(send_buf,TEST_SIZE)
76 call MPI_Send(send_buf, count, MPI_REAL, next, tag, &
79 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
80 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
82 call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
83 & 'send and recv', errs )
84 else if (prev .eq. 0) then
85 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
86 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
88 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
89 & 'send and recv', errs )
91 call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr)
96 subroutine test_pair_rsend( comm, errs )
99 integer rank, size, ierr, next, prev, tag, count, i
101 parameter (TEST_SIZE=2000)
102 integer status(MPI_STATUS_SIZE), requests(1)
103 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
105 common /flags/ verbose
108 print *, ' Rsend and recv'
112 call mpi_comm_rank( comm, rank, ierr )
113 call mpi_comm_size( comm, size, ierr )
115 if (next .ge. size) next = 0
118 if (prev .lt. 0) prev = size - 1
121 count = TEST_SIZE / 3
123 call clear_test_data(recv_buf,TEST_SIZE)
125 if (rank .eq. 0) then
127 call init_test_data(send_buf,TEST_SIZE)
129 call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, &
130 & comm, status, ierr )
132 call MPI_Rsend(send_buf, count, MPI_REAL, next, tag, &
135 call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr)
137 if (status(MPI_SOURCE) .ne. next) then
138 print *, 'Rsend: Incorrect source, expected', next, &
139 & ', got', status(MPI_SOURCE)
143 if (status(MPI_TAG) .ne. tag) then
144 print *, 'Rsend: Incorrect tag, expected', tag, &
145 & ', got', status(MPI_TAG)
149 call MPI_Get_count(status, MPI_REAL, i, ierr)
151 if (i .ne. count) then
152 print *, 'Rsend: Incorrect count, expected', count, &
157 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
158 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
161 call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
162 & 'rsend and recv', errs )
164 else if (prev .eq. 0) then
166 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
167 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
169 call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag, &
171 call MPI_Wait( requests(1), status, ierr )
172 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
173 & 'rsend and recv', errs )
175 call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
181 subroutine test_pair_ssend( comm, errs )
184 integer rank, size, ierr, next, prev, tag, count, i
186 parameter (TEST_SIZE=2000)
187 integer status(MPI_STATUS_SIZE)
189 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
191 common /flags/ verbose
194 print *, ' Ssend and recv'
198 call mpi_comm_rank( comm, rank, ierr )
199 call mpi_comm_size( comm, size, ierr )
201 if (next .ge. size) next = 0
204 if (prev .lt. 0) prev = size - 1
207 count = TEST_SIZE / 3
209 call clear_test_data(recv_buf,TEST_SIZE)
211 if (rank .eq. 0) then
213 call init_test_data(send_buf,TEST_SIZE)
215 call MPI_Iprobe(MPI_ANY_SOURCE, tag, &
216 & comm, flag, status, ierr)
219 print *, 'Ssend: Iprobe succeeded! source', &
220 & status(MPI_SOURCE), &
221 & ', tag', status(MPI_TAG)
225 call MPI_Ssend(send_buf, count, MPI_REAL, next, tag, &
228 do while (.not. flag)
229 call MPI_Iprobe(MPI_ANY_SOURCE, tag, &
230 & comm, flag, status, ierr)
233 if (status(MPI_SOURCE) .ne. next) then
234 print *, 'Ssend: Incorrect source, expected', next, &
235 & ', got', status(MPI_SOURCE)
239 if (status(MPI_TAG) .ne. tag) then
240 print *, 'Ssend: Incorrect tag, expected', tag, &
241 & ', got', status(MPI_TAG)
245 call MPI_Get_count(status, MPI_REAL, i, ierr)
247 if (i .ne. count) then
248 print *, 'Ssend: Incorrect count, expected', count, &
253 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
254 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
257 call msg_check( recv_buf, next, tag, count, status, &
258 & TEST_SIZE, 'ssend and recv', errs )
260 else if (prev .eq. 0) then
262 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
263 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
266 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
267 & 'ssend and recv', errs )
269 call MPI_Ssend(recv_buf, count, MPI_REAL, prev, tag, &
275 subroutine test_pair_isend( comm, errs )
278 integer rank, size, ierr, next, prev, tag, count
280 parameter (TEST_SIZE=2000)
281 integer status(MPI_STATUS_SIZE), requests(2)
282 integer statuses(MPI_STATUS_SIZE,2)
283 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
285 common /flags/ verbose
288 print *, ' isend and irecv'
292 call mpi_comm_rank( comm, rank, ierr )
293 call mpi_comm_size( comm, size, ierr )
295 if (next .ge. size) next = 0
298 if (prev .lt. 0) prev = size - 1
301 count = TEST_SIZE / 5
303 call clear_test_data(recv_buf,TEST_SIZE)
305 if (rank .eq. 0) then
307 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
308 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
311 call init_test_data(send_buf,TEST_SIZE)
313 call MPI_Isend(send_buf, count, MPI_REAL, next, tag, &
314 & comm, requests(2), ierr)
316 call MPI_Waitall(2, requests, statuses, ierr)
318 call rq_check( requests, 2, 'isend and irecv' )
320 call msg_check( recv_buf, next, tag, count, statuses(1,1), &
321 & TEST_SIZE, 'isend and irecv', errs )
323 else if (prev .eq. 0) then
325 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
326 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
329 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
330 & 'isend and irecv', errs )
332 call MPI_Isend(recv_buf, count, MPI_REAL, prev, tag, &
333 & comm, requests(1), ierr)
335 call MPI_Wait(requests(1), status, ierr)
337 call rq_check( requests(1), 1, 'isend and irecv' )
343 subroutine test_pair_irsend( comm, errs )
346 integer rank, size, ierr, next, prev, tag, count, index
349 parameter (TEST_SIZE=2000)
350 integer status(MPI_STATUS_SIZE), requests(2)
351 integer statuses(MPI_STATUS_SIZE,2)
353 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
355 common /flags/ verbose
358 print *, ' Irsend and irecv'
361 call mpi_comm_rank( comm, rank, ierr )
362 call mpi_comm_size( comm, size, ierr )
364 if (next .ge. size) next = 0
367 if (prev .lt. 0) prev = size - 1
369 call mpi_comm_dup( comm, dupcom, ierr )
372 count = TEST_SIZE / 3
374 call clear_test_data(recv_buf,TEST_SIZE)
376 if (rank .eq. 0) then
378 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
379 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
382 call init_test_data(send_buf,TEST_SIZE)
384 call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0, &
385 & MPI_BOTTOM, 0, MPI_INTEGER, next, 0, &
386 & dupcom, status, ierr )
388 call MPI_Irsend(send_buf, count, MPI_REAL, next, tag, &
389 & comm, requests(2), ierr)
392 do while (index .ne. 1)
393 call MPI_Waitany(2, requests, index, statuses, ierr)
396 call rq_check( requests(1), 1, 'irsend and irecv' )
398 call msg_check( recv_buf, next, tag, count, statuses, &
399 & TEST_SIZE, 'irsend and irecv', errs )
401 else if (prev .eq. 0) then
403 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
404 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
407 call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, prev, 0, &
408 & MPI_BOTTOM, 0, MPI_INTEGER, prev, 0, &
409 & dupcom, status, ierr )
412 do while (.not. flag)
413 call MPI_Test(requests(1), flag, status, ierr)
416 call rq_check( requests, 1, 'irsend and irecv (test)' )
418 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
419 & 'irsend and irecv', errs )
421 call MPI_Irsend(recv_buf, count, MPI_REAL, prev, tag, &
422 & comm, requests(1), ierr)
424 call MPI_Waitall(1, requests, statuses, ierr)
426 call rq_check( requests, 1, 'irsend and irecv' )
430 call mpi_comm_free( dupcom, ierr )
434 subroutine test_pair_issend( comm, errs )
437 integer rank, size, ierr, next, prev, tag, count, index
439 parameter (TEST_SIZE=2000)
440 integer status(MPI_STATUS_SIZE), requests(2)
441 integer statuses(MPI_STATUS_SIZE,2)
443 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
445 common /flags/ verbose
448 print *, ' issend and irecv (testall)'
452 call mpi_comm_rank( comm, rank, ierr )
453 call mpi_comm_size( comm, size, ierr )
455 if (next .ge. size) next = 0
458 if (prev .lt. 0) prev = size - 1
461 count = TEST_SIZE / 3
463 call clear_test_data(recv_buf,TEST_SIZE)
465 if (rank .eq. 0) then
467 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
468 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
471 call init_test_data(send_buf,TEST_SIZE)
473 call MPI_Issend(send_buf, count, MPI_REAL, next, tag, &
474 & comm, requests(2), ierr)
477 do while (.not. flag)
478 call MPI_Testall(2, requests, flag, statuses, ierr)
481 call rq_check( requests, 2, 'issend and irecv (testall)' )
483 call msg_check( recv_buf, next, tag, count, statuses(1,1), &
484 & TEST_SIZE, 'issend and recv (testall)', errs )
486 else if (prev .eq. 0) then
488 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
489 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
492 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
493 & 'issend and recv', errs )
495 call MPI_Issend(recv_buf, count, MPI_REAL, prev, tag, &
496 & comm, requests(1), ierr)
499 do while (.not. flag)
500 call MPI_Testany(1, requests(1), index, flag, &
501 & statuses(1,1), ierr)
504 call rq_check( requests, 1, 'issend and recv (testany)' )
510 subroutine test_pair_psend( comm, errs )
513 integer rank, size, ierr, next, prev, tag, count, i
515 parameter (TEST_SIZE=2000)
516 integer status(MPI_STATUS_SIZE)
517 integer statuses(MPI_STATUS_SIZE,2), requests(2)
518 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
520 common /flags/ verbose
523 print *, ' Persistent send and recv'
526 call mpi_comm_rank( comm, rank, ierr )
527 call mpi_comm_size( comm, size, ierr )
529 if (next .ge. size) next = 0
532 if (prev .lt. 0) prev = size - 1
535 count = TEST_SIZE / 5
537 call clear_test_data(recv_buf,TEST_SIZE)
538 call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, &
539 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
542 if (rank .eq. 0) then
544 call init_test_data(send_buf,TEST_SIZE)
546 call MPI_Send_init(send_buf, count, MPI_REAL, next, tag, &
547 & comm, requests(1), ierr)
549 call MPI_Startall(2, requests, ierr)
550 call MPI_Waitall(2, requests, statuses, ierr)
552 call msg_check( recv_buf, next, tag, count, statuses(1,2), &
553 & TEST_SIZE, 'persistent send/recv', errs )
555 call MPI_Request_free(requests(1), ierr)
557 else if (prev .eq. 0) then
559 call MPI_Send_init(send_buf, count, MPI_REAL, prev, tag, &
560 & comm, requests(1), ierr)
561 call MPI_Start(requests(2), ierr)
562 call MPI_Wait(requests(2), status, ierr)
564 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
565 & 'persistent send/recv', errs )
568 send_buf(i) = recv_buf(i)
571 call MPI_Start(requests(1), ierr)
572 call MPI_Wait(requests(1), status, ierr)
574 call MPI_Request_free(requests(1), ierr)
577 call dummyRef( send_buf, count, ierr )
578 call MPI_Request_free(requests(2), ierr)
582 subroutine test_pair_prsend( comm, errs )
585 integer rank, size, ierr, next, prev, tag, count, index, i
586 integer outcount, indices(2)
588 parameter (TEST_SIZE=2000)
589 integer statuses(MPI_STATUS_SIZE,2), requests(2)
590 integer status(MPI_STATUS_SIZE)
592 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
594 common /flags/ verbose
597 print *, ' Persistent Rsend and recv'
600 call mpi_comm_rank( comm, rank, ierr )
601 call mpi_comm_size( comm, size, ierr )
603 if (next .ge. size) next = 0
606 if (prev .lt. 0) prev = size - 1
609 count = TEST_SIZE / 3
611 call clear_test_data(recv_buf,TEST_SIZE)
613 call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, &
614 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
617 if (rank .eq. 0) then
619 call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag, &
620 & comm, requests(1), ierr)
622 call init_test_data(send_buf,TEST_SIZE)
624 call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag, &
625 & comm, status, ierr )
627 call MPI_Startall(2, requests, ierr)
631 do while (index .ne. 2)
632 call MPI_Waitsome(2, requests, outcount, &
633 & indices, statuses, ierr)
635 if (indices(i) .eq. 2) then
636 call msg_check( recv_buf, next, tag, count, &
637 & statuses(1,i), TEST_SIZE, 'waitsome', errs )
643 call MPI_Request_free(requests(1), ierr)
644 else if (prev .eq. 0) then
646 call MPI_Rsend_init(send_buf, count, MPI_REAL, prev, tag, &
647 & comm, requests(1), ierr)
649 call MPI_Start(requests(2), ierr)
651 call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag, &
655 do while (.not. flag)
656 call MPI_Test(requests(2), flag, status, ierr)
658 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
662 send_buf(i) = recv_buf(i)
665 call MPI_Start(requests(1), ierr)
666 call MPI_Wait(requests(1), status, ierr)
668 call MPI_Request_free(requests(1), ierr)
671 call dummyRef( send_buf, count, ierr )
672 call MPI_Request_free(requests(2), ierr)
676 subroutine test_pair_pssend( comm, errs )
679 integer rank, size, ierr, next, prev, tag, count, index, i
680 integer outcount, indices(2)
682 parameter (TEST_SIZE=2000)
683 integer statuses(MPI_STATUS_SIZE,2), requests(2)
684 integer status(MPI_STATUS_SIZE)
686 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
688 common /flags/ verbose
691 print *, ' Persistent Ssend and recv'
694 call mpi_comm_rank( comm, rank, ierr )
695 call mpi_comm_size( comm, size, ierr )
697 if (next .ge. size) next = 0
700 if (prev .lt. 0) prev = size - 1
703 count = TEST_SIZE / 3
705 call clear_test_data(recv_buf,TEST_SIZE)
707 call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, &
708 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
711 if (rank .eq. 0) then
713 call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag, &
714 & comm, requests(2), ierr)
716 call init_test_data(send_buf,TEST_SIZE)
718 call MPI_Startall(2, requests, ierr)
721 do while (index .ne. 1)
722 call MPI_Testsome(2, requests, outcount, &
723 & indices, statuses, ierr)
725 if (indices(i) .eq. 1) then
726 call msg_check( recv_buf, next, tag, count, &
727 & statuses(1,i), TEST_SIZE, 'testsome', errs )
733 call MPI_Request_free(requests(2), ierr)
735 else if (prev .eq. 0) then
737 call MPI_Ssend_init(send_buf, count, MPI_REAL, prev, tag, &
738 & comm, requests(2), ierr)
740 call MPI_Start(requests(1), ierr)
743 do while (.not. flag)
744 call MPI_Testany(1, requests(1), index, flag, &
745 & statuses(1,1), ierr)
747 call msg_check( recv_buf, prev, tag, count, statuses(1,1), &
748 & TEST_SIZE, 'testany', errs )
751 send_buf(i) = recv_buf(i)
754 call MPI_Start(requests(2), ierr)
755 call MPI_Wait(requests(2), status, ierr)
757 call MPI_Request_free(requests(2), ierr)
761 call dummyRef( send_buf, count, ierr )
762 call MPI_Request_free(requests(1), ierr)
766 subroutine test_pair_sendrecv( comm, errs )
769 integer rank, size, ierr, next, prev, tag, count
771 parameter (TEST_SIZE=2000)
772 integer status(MPI_STATUS_SIZE)
773 real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
775 common /flags/ verbose
782 call mpi_comm_rank( comm, rank, ierr )
783 call mpi_comm_size( comm, size, ierr )
785 if (next .ge. size) next = 0
788 if (prev .lt. 0) prev = size - 1
791 count = TEST_SIZE / 5
793 call clear_test_data(recv_buf,TEST_SIZE)
795 if (rank .eq. 0) then
797 call init_test_data(send_buf,TEST_SIZE)
799 call MPI_Sendrecv(send_buf, count, MPI_REAL, next, tag, &
800 & recv_buf, count, MPI_REAL, next, tag, &
801 & comm, status, ierr)
803 call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
806 else if (prev .eq. 0) then
808 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
809 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
812 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
813 & 'recv/send', errs )
815 call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
821 subroutine test_pair_sendrecvrepl( comm, errs )
824 integer rank, size, ierr, next, prev, tag, count, i
826 parameter (TEST_SIZE=2000)
827 integer status(MPI_STATUS_SIZE)
828 real recv_buf(TEST_SIZE)
830 common /flags/ verbose
833 print *, ' Sendrecv replace'
836 call mpi_comm_rank( comm, rank, ierr )
837 call mpi_comm_size( comm, size, ierr )
839 if (next .ge. size) next = 0
842 if (prev .lt. 0) prev = size - 1
845 count = TEST_SIZE / 3
847 if (rank .eq. 0) then
849 call init_test_data(recv_buf, TEST_SIZE)
851 do 11 i = count+1,TEST_SIZE
855 call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL, &
856 & next, tag, next, tag, &
857 & comm, status, ierr)
859 call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
860 & 'sendrecvreplace', errs )
862 else if (prev .eq. 0) then
864 call clear_test_data(recv_buf,TEST_SIZE)
866 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
867 & MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
870 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
871 & 'recv/send for replace', errs )
873 call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
879 !------------------------------------------------------------------------------
881 ! Check for correct source, tag, count, and data in test message.
883 !------------------------------------------------------------------------------
884 subroutine msg_check( recv_buf, source, tag, count, status, n, &
889 integer source, tag, count, rank, status(MPI_STATUS_SIZE)
893 integer ierr, recv_src, recv_tag, recv_count
896 recv_src = status(MPI_SOURCE)
897 recv_tag = status(MPI_TAG)
898 call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
899 call MPI_Get_count(status, MPI_REAL, recv_count, ierr)
901 if (recv_src .ne. source) then
902 print *, '[', rank, '] Unexpected source:', recv_src, &
908 if (recv_tag .ne. tag) then
909 print *, '[', rank, '] Unexpected tag:', recv_tag, ' in ', name
914 if (recv_count .ne. count) then
915 print *, '[', rank, '] Unexpected count:', recv_count, &
921 call verify_test_data(recv_buf, count, n, name, errs )
924 !------------------------------------------------------------------------------
926 ! Check that requests have been set to null
928 !------------------------------------------------------------------------------
929 subroutine rq_check( requests, n, msg )
931 integer n, requests(n)
936 if (requests(i) .ne. MPI_REQUEST_NULL) then
937 print *, 'Nonnull request in ', msg
942 !------------------------------------------------------------------------------
944 ! Initialize test data buffer with integral sequence.
946 !------------------------------------------------------------------------------
947 subroutine init_test_data(buf,n)
957 !------------------------------------------------------------------------------
959 ! Clear test data buffer
961 !------------------------------------------------------------------------------
962 subroutine clear_test_data(buf, n)
973 !------------------------------------------------------------------------------
975 ! Verify test data buffer
977 !------------------------------------------------------------------------------
978 subroutine verify_test_data( buf, count, n, name, errs )
986 if (buf(i) .ne. REAL(i)) then
987 print 100, buf(i), i, count, name
992 do 20 i = count + 1, n
993 if (buf(i) .ne. 0.) then
994 print 100, buf(i), i, n, name
999 100 format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)
1003 ! This routine is used to prevent the compiler from deallocating the
1004 ! array "a", which may happen in some of the tests (see the text in
1005 ! the MPI standard about why this may be a problem in valid Fortran
1006 ! codes). Without this, for example, tests fail with the Cray ftn
1009 subroutine dummyRef( a, n, ie )
1012 ! This condition will never be true, but the compile won't know that
1013 if (ie .eq. -1) then