2 c This program was inspired by a bug report from
3 c fsset@corelli.lerc.nasa.gov (Scott Townsend)
4 c The original version of this program was submitted by email to
5 c mpi-bugs and is in the directory mpich/bugs/ssend (not distributed
6 c with the distribution). This program was modified by William
7 c Gropp (to correct a few errors and make more consistent with the
8 c structure of the test programs in the examples/test/pt2pt directory.
10 c A C version of this program is in allpairc.c
12 c This version is intended to test for memory leaks; it runs each test
13 c a number of times (TEST_COUNT + some in test_pair).
23 call MPI_Finalize(ierr)
27 c------------------------------------------------------------------------------
29 c Simple pair communication exercises.
31 c------------------------------------------------------------------------------
34 integer TEST_SIZE, TEST_COUNT
35 parameter (TEST_SIZE=2000)
36 parameter (TEST_COUNT=100)
38 integer ierr, prev, next, count, tag, index, i, outcount,
39 . requests(2), indices(2), rank, size,
40 . status(MPI_STATUS_SIZE), statuses(MPI_STATUS_SIZE,2)
44 real send_buf( TEST_SIZE ), recv_buf ( TEST_SIZE )
46 call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
47 call MPI_Comm_size( MPI_COMM_WORLD, size, ierr )
48 call MPI_Comm_dup( MPI_COMM_WORLD, dupcom, ierr )
50 if (next .ge. size) next = 0
53 if (prev .lt. 0) prev = size - 1
64 do 111 c=1, TEST_COUNT+1
66 call clear_test_data(recv_buf,TEST_SIZE)
70 call init_test_data(send_buf,TEST_SIZE)
72 call MPI_Send(send_buf, count, MPI_REAL, next, tag,
73 . MPI_COMM_WORLD, ierr)
75 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
76 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
79 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
84 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
85 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
88 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
91 call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
92 . MPI_COMM_WORLD, ierr)
96 c Ready sends. Note that we must ensure that the receive is posted
97 c before the rsend; this requires using Irecv.
104 count = TEST_SIZE / 3
106 do 112 c = 1, TEST_COUNT+2
107 call clear_test_data(recv_buf,TEST_SIZE)
109 if (rank .eq. 0) then
111 call init_test_data(send_buf,TEST_SIZE)
113 call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
114 . MPI_COMM_WORLD, status, ierr )
116 call MPI_Rsend(send_buf, count, MPI_REAL, next, tag,
117 . MPI_COMM_WORLD, ierr)
119 call MPI_Probe(MPI_ANY_SOURCE, tag,
120 . MPI_COMM_WORLD, status, ierr)
122 if (status(MPI_SOURCE) .ne. prev) then
123 print *, 'Incorrect source, expected', prev,
124 . ', got', status(MPI_SOURCE)
127 if (status(MPI_TAG) .ne. tag) then
128 print *, 'Incorrect tag, expected', tag,
129 . ', got', status(MPI_TAG)
132 call MPI_Get_count(status, MPI_REAL, i, ierr)
134 if (i .ne. count) then
135 print *, 'Incorrect count, expected', count,
139 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
140 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
143 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
148 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
149 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
151 call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
152 . MPI_COMM_WORLD, ierr )
153 call MPI_Wait( requests(1), status, ierr )
155 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
158 call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
159 . MPI_COMM_WORLD, ierr)
165 if (rank .eq. 0) then
170 count = TEST_SIZE / 3
172 do 113 c = 1, TEST_COUNT+3
173 call clear_test_data(recv_buf,TEST_SIZE)
175 if (rank .eq. 0) then
177 call init_test_data(send_buf,TEST_SIZE)
179 call MPI_Iprobe(MPI_ANY_SOURCE, tag,
180 . MPI_COMM_WORLD, flag, status, ierr)
183 print *, 'Iprobe succeeded! source', status(MPI_SOURCE),
184 . ', tag', status(MPI_TAG)
187 call MPI_Ssend(send_buf, count, MPI_REAL, next, tag,
188 . MPI_COMM_WORLD, ierr)
190 do while (.not. flag)
191 call MPI_Iprobe(MPI_ANY_SOURCE, tag,
192 . MPI_COMM_WORLD, flag, status, ierr)
195 if (status(MPI_SOURCE) .ne. prev) then
196 print *, 'Incorrect source, expected', prev,
197 . ', got', status(MPI_SOURCE)
200 if (status(MPI_TAG) .ne. tag) then
201 print *, 'Incorrect tag, expected', tag,
202 . ', got', status(MPI_TAG)
205 call MPI_Get_count(status, MPI_REAL, i, ierr)
207 if (i .ne. count) then
208 print *, 'Incorrect count, expected', count,
212 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
213 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
216 call msg_check( recv_buf, prev, tag, count, status,
217 $ TEST_SIZE, 'ssend and recv' )
221 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
222 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
225 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
228 call MPI_Ssend(recv_buf, count, MPI_REAL, next, tag,
229 . MPI_COMM_WORLD, ierr)
233 c Nonblocking normal sends
235 if (rank .eq. 0) then
240 count = TEST_SIZE / 5
242 do 114 c = 1, TEST_COUNT+4
243 call clear_test_data(recv_buf,TEST_SIZE)
245 if (rank .eq. 0) then
247 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
248 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
251 call init_test_data(send_buf,TEST_SIZE)
253 call MPI_Isend(send_buf, count, MPI_REAL, next, tag,
254 . MPI_COMM_WORLD, requests(2), ierr)
256 call MPI_Waitall(2, requests, statuses, ierr)
258 call rq_check( requests, 2, 'isend and irecv' )
260 call msg_check( recv_buf, prev, tag, count, statuses(1,1),
261 $ TEST_SIZE, 'isend and irecv' )
265 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
266 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
269 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
270 . 'isend and irecv' )
272 call MPI_Isend(recv_buf, count, MPI_REAL, next, tag,
273 . MPI_COMM_WORLD, requests(1), ierr)
275 call MPI_Wait(requests(1), status, ierr)
277 call rq_check( requests(1), 1, 'isend and irecv' )
282 c Nonblocking ready sends
284 if (rank .eq. 0) then
289 count = TEST_SIZE / 3
291 do 115 c = 1, TEST_COUNT+5
292 call clear_test_data(recv_buf,TEST_SIZE)
294 if (rank .eq. 0) then
296 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
297 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
300 call init_test_data(send_buf,TEST_SIZE)
302 call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
303 . MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
304 . dupcom, status, ierr )
306 call MPI_Irsend(send_buf, count, MPI_REAL, next, tag,
307 . MPI_COMM_WORLD, requests(2), ierr)
310 do while (index .ne. 1)
311 call MPI_Waitany(2, requests, index, statuses, ierr)
314 call rq_check( requests(1), 1, 'irsend and irecv' )
316 call msg_check( recv_buf, prev, tag, count, statuses,
317 $ TEST_SIZE, 'irsend and irecv' )
320 C In case the send didn't complete yet.
321 call MPI_Waitall( 2, requests, statuses, ierr )
325 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
326 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
329 call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
330 . MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
331 . dupcom, status, ierr )
334 do while (.not. flag)
335 call MPI_Test(requests(1), flag, status, ierr)
338 call rq_check( requests, 1, 'irsend and irecv (test)' )
340 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
341 . 'irsend and irecv' )
343 call MPI_Irsend(recv_buf, count, MPI_REAL, next, tag,
344 . MPI_COMM_WORLD, requests(1), ierr)
346 call MPI_Waitall(1, requests, statuses, ierr)
348 call rq_check( requests, 1, 'irsend and irecv' )
353 c Nonblocking synchronous sends
355 if (rank .eq. 0) then
360 count = TEST_SIZE / 3
362 do 116 c = 1, TEST_COUNT+6
363 call clear_test_data(recv_buf,TEST_SIZE)
365 if (rank .eq. 0) then
367 call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
368 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
371 call init_test_data(send_buf,TEST_SIZE)
373 call MPI_Issend(send_buf, count, MPI_REAL, next, tag,
374 . MPI_COMM_WORLD, requests(2), ierr)
377 do while (.not. flag)
378 call MPI_Testall(2, requests, flag, statuses, ierr)
379 C print *, 'flag = ', flag
382 call rq_check( requests, 2, 'issend and irecv (testall)' )
384 call msg_check( recv_buf, prev, tag, count, statuses(1,1),
385 $ TEST_SIZE, 'issend and recv (testall)' )
389 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
390 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
393 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
394 . 'issend and recv' )
396 call MPI_Issend(recv_buf, count, MPI_REAL, next, tag,
397 . MPI_COMM_WORLD, requests(1), ierr)
400 do while (.not. flag)
401 call MPI_Testany(1, requests(1), index, flag,
402 . statuses(1,1), ierr)
403 c print *, 'flag = ', flag
406 call rq_check( requests, 1, 'issend and recv (testany)' )
411 c Persistent normal sends
413 if (rank .eq. 0) then
414 print *, ' Send_init'
418 count = TEST_SIZE / 5
420 do 117 c = 1, TEST_COUNT+7
421 call clear_test_data(recv_buf,TEST_SIZE)
423 call MPI_Send_init(send_buf, count, MPI_REAL, next, tag,
424 . MPI_COMM_WORLD, requests(1), ierr)
426 call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
427 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
430 if (rank .eq. 0) then
432 call init_test_data(send_buf,TEST_SIZE)
434 call MPI_Startall(2, requests, ierr)
435 call MPI_Waitall(2, requests, statuses, ierr)
437 call msg_check( recv_buf, prev, tag, count, statuses(1,2),
438 $ TEST_SIZE, 'persistent send/recv' )
442 call MPI_Start(requests(2), ierr)
443 call MPI_Wait(requests(2), status, ierr)
445 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
446 * 'persistent send/recv')
449 send_buf(i) = recv_buf(i)
452 call MPI_Start(requests(1), ierr)
453 call MPI_Wait(requests(1), status, ierr)
457 call MPI_Request_free(requests(1), ierr)
458 call MPI_Request_free(requests(2), ierr)
461 c Persistent ready sends
462 c Like the ready send, we must ensure that the receive is posted
463 c before the ready send is started.
465 if (rank .eq. 0) then
466 print *, ' Rsend_init'
470 count = TEST_SIZE / 3
472 do 118 c = 1, TEST_COUNT+8
473 call clear_test_data(recv_buf,TEST_SIZE)
475 call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag,
476 . MPI_COMM_WORLD, requests(1), ierr)
478 call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
479 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
483 c receive a clear-to-go from the destination, so that the ready send
484 c will find the matching receive when it arrives
486 if (rank .eq. 0) then
488 call init_test_data(send_buf,TEST_SIZE)
490 call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, 1, 321,
491 $ MPI_COMM_WORLD, status, ierr )
492 call MPI_Startall(2, requests, ierr)
495 do while (index .ne. 2)
496 call MPI_Waitsome(2, requests, outcount,
497 . indices, statuses, ierr)
499 if (indices(i) .eq. 2) then
500 call msg_check( recv_buf, prev, tag, count,
501 $ statuses(1,i), TEST_SIZE, 'waitsome' )
509 call MPI_Start(requests(2), ierr)
511 c Let the target know that is may begin the ready send
512 call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, 0, 321,
513 $ MPI_COMM_WORLD, ierr )
516 do while (.not. flag)
517 call MPI_Test(requests(2), flag, status, ierr)
520 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
524 send_buf(i) = recv_buf(i)
527 call MPI_Start(requests(1), ierr)
528 call MPI_Wait(requests(1), status, ierr)
532 call MPI_Request_free(requests(1), ierr)
533 call MPI_Request_free(requests(2), ierr)
536 c Persistent synchronous sends
538 if (rank .eq. 0) then
539 print *, ' Ssend_init'
543 count = TEST_SIZE / 3
545 do 119 c = 1, TEST_COUNT+9
546 call clear_test_data(recv_buf,TEST_SIZE)
548 call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag,
549 . MPI_COMM_WORLD, requests(2), ierr)
551 call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
552 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
555 if (rank .eq. 0) then
557 call init_test_data(send_buf,TEST_SIZE)
559 call MPI_Startall(2, requests, ierr)
562 do while (index .ne. 1)
563 call MPI_Testsome(2, requests, outcount,
564 . indices, statuses, ierr)
566 if (indices(i) .eq. 1) then
567 call msg_check( recv_buf, prev, tag, count,
568 $ statuses(1,i), TEST_SIZE, 'testsome' )
576 call MPI_Start(requests(1), ierr)
579 do while (.not. flag)
580 call MPI_Testany(1, requests(1), index, flag,
581 . statuses(1,1), ierr)
584 call msg_check( recv_buf, prev, tag, count, statuses(1,1),
585 $ TEST_SIZE, 'testany' )
588 send_buf(i) = recv_buf(i)
591 call MPI_Start(requests(2), ierr)
592 call MPI_Wait(requests(2), status, ierr)
596 call MPI_Request_free(requests(1), ierr)
597 call MPI_Request_free(requests(2), ierr)
602 if (rank .eq. 0) then
607 count = TEST_SIZE / 5
609 do 120 c = 1, TEST_COUNT+10
610 call clear_test_data(recv_buf,TEST_SIZE)
612 if (rank .eq. 0) then
614 call init_test_data(send_buf,TEST_SIZE)
616 call MPI_Sendrecv(send_buf, count, MPI_REAL, next, tag,
617 . recv_buf, count, MPI_REAL, prev, tag,
618 . MPI_COMM_WORLD, status, ierr)
620 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
625 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
626 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
629 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
632 call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
633 . MPI_COMM_WORLD, ierr)
637 c Send/receive replace.
639 if (rank .eq. 0) then
640 print *, ' Sendrecv_replace'
644 count = TEST_SIZE / 3
646 do 121 c = 1, TEST_COUNT+11
647 if (rank .eq. 0) then
649 call init_test_data(recv_buf, TEST_SIZE)
651 do 11 i = count+1,TEST_SIZE
655 call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL,
656 . next, tag, prev, tag,
657 . MPI_COMM_WORLD, status, ierr)
659 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
660 . 'sendrecvreplace' )
664 call clear_test_data(recv_buf,TEST_SIZE)
666 call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
667 . MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
670 call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
671 . 'recv/send for replace' )
673 call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
674 . MPI_COMM_WORLD, ierr)
679 call MPI_Comm_free( dupcom, ierr )
684 c------------------------------------------------------------------------------
686 c Check for correct source, tag, count, and data in test message.
688 c------------------------------------------------------------------------------
689 subroutine msg_check( recv_buf, source, tag, count, status, n,
694 integer source, tag, count, rank, status(MPI_STATUS_SIZE)
697 integer ierr, recv_src, recv_tag, recv_count
699 recv_src = status(MPI_SOURCE)
700 recv_tag = status(MPI_TAG)
701 call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
702 call MPI_Get_count(status, MPI_REAL, recv_count, ierr)
704 C Check for null status
705 if (recv_src .eq. MPI_ANY_SOURCE .and.
706 * recv_tag .eq. MPI_ANY_TAG .and.
707 * status(MPI_ERROR) .eq. MPI_SUCCESS) then
708 print *, '[', rank, '] Unexpected NULL status in ', name
709 call MPI_Abort( MPI_COMM_WORLD, 104, ierr )
711 if (recv_src .ne. source) then
712 print *, '[', rank, '] Unexpected source:', recv_src,
714 call MPI_Abort(MPI_COMM_WORLD, 101, ierr)
717 if (recv_tag .ne. tag) then
718 print *, '[', rank, '] Unexpected tag:', recv_tag, ' in ', name
719 call MPI_Abort(MPI_COMM_WORLD, 102, ierr)
722 if (recv_count .ne. count) then
723 print *, '[', rank, '] Unexpected count:', recv_count,
725 call MPI_Abort(MPI_COMM_WORLD, 103, ierr)
728 call verify_test_data(recv_buf, count, n, name )
731 c------------------------------------------------------------------------------
733 c Check that requests have been set to null
735 c------------------------------------------------------------------------------
736 subroutine rq_check( requests, n, msg )
738 integer n, requests(n)
743 if (requests(i) .ne. MPI_REQUEST_NULL) then
744 print *, 'Nonnull request in ', msg
749 c------------------------------------------------------------------------------
751 c Initialize test data buffer with integral sequence.
753 c------------------------------------------------------------------------------
754 subroutine init_test_data(buf,n)
764 c------------------------------------------------------------------------------
766 c Clear test data buffer
768 c------------------------------------------------------------------------------
769 subroutine clear_test_data(buf, n)
780 c------------------------------------------------------------------------------
782 c Verify test data buffer
784 c------------------------------------------------------------------------------
785 subroutine verify_test_data(buf, count, n, name)
791 integer count, ierr, i
794 if (buf(i) .ne. REAL(i)) then
795 print 100, buf(i), i, count, name
796 call MPI_Abort(MPI_COMM_WORLD, 108, ierr)
800 do 20 i = count + 1, n
801 if (buf(i) .ne. 0.) then
802 print 100, buf(i), i, n, name
803 call MPI_Abort(MPI_COMM_WORLD, 109, ierr)
807 100 format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)