Logo AND Algorithmique Numérique Distribuée

Public GIT Repository
these can now be activated
[simgrid.git] / teshsuite / smpi / mpich3-test / f90 / pt2pt / allpairf90.f90
1 ! This file created from test/mpi/f77/pt2pt/allpairf.f with f77tof90
2 ! -*- Mode: Fortran; -*- 
3 !
4 !  (C) 2012 by Argonne National Laboratory.
5 !      See COPYRIGHT in top-level directory.
6 !
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)
10
11       program allpair
12       use mpi
13       integer ierr, errs, comm
14       logical mtestGetIntraComm
15       logical verbose
16       common /flags/ verbose
17       
18       errs = 0
19       verbose = .false.
20 !      verbose = .true.
21       call MTest_Init( ierr )
22
23       do while ( mtestGetIntraComm( comm, 2, .false. ) )
24
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 )
37       enddo
38 !         
39       call MTest_Finalize( errs )
40       call MPI_Finalize(ierr)
41 !
42       end
43 !
44       subroutine test_pair_send( comm, errs )
45       use mpi
46       integer comm, errs
47       integer rank, size, ierr, next, prev, tag, count
48       integer TEST_SIZE
49       parameter (TEST_SIZE=2000)
50       integer status(MPI_STATUS_SIZE)
51       real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
52       logical verbose
53       common /flags/ verbose
54 !
55       if (verbose) then
56          print *, ' Send and recv'
57       endif
58 !
59       call mpi_comm_rank( comm, rank, ierr )
60       call mpi_comm_size( comm, size, ierr )
61       next = rank + 1
62       if (next .ge. size) next = 0
63 !
64       prev = rank - 1
65       if (prev .lt. 0) prev = size - 1
66 !
67       tag = 1123
68       count = TEST_SIZE / 5
69 !
70       call clear_test_data(recv_buf,TEST_SIZE)
71 !
72       if (rank .eq. 0) then
73 !
74          call init_test_data(send_buf,TEST_SIZE)
75 !
76          call MPI_Send(send_buf, count, MPI_REAL, next, tag, &
77       &        comm, ierr) 
78 !
79          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
80       &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, status, ierr)
81 !
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)
87
88          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
89       &                   'send and recv', errs )
90 !
91          call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, comm, ierr) 
92       end if
93 !
94       end
95 !
96       subroutine test_pair_rsend( comm, errs )
97       use mpi
98       integer comm, errs
99       integer rank, size, ierr, next, prev, tag, count, i
100       integer TEST_SIZE
101       parameter (TEST_SIZE=2000)
102       integer status(MPI_STATUS_SIZE), requests(1)
103       real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
104       logical verbose
105       common /flags/ verbose
106 !
107       if (verbose) then
108          print *, ' Rsend and recv'
109       endif
110 !
111 !
112       call mpi_comm_rank( comm, rank, ierr )
113       call mpi_comm_size( comm, size, ierr )
114       next = rank + 1
115       if (next .ge. size) next = 0
116 !
117       prev = rank - 1
118       if (prev .lt. 0) prev = size - 1
119 !
120       tag = 1456
121       count = TEST_SIZE / 3
122 !
123       call clear_test_data(recv_buf,TEST_SIZE)
124 !
125       if (rank .eq. 0) then
126 !        
127          call init_test_data(send_buf,TEST_SIZE)
128 !
129          call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,  &
130       &                  comm, status, ierr )
131 !
132          call MPI_Rsend(send_buf, count, MPI_REAL, next, tag, &
133       &                  comm, ierr) 
134 !
135          call MPI_Probe(MPI_ANY_SOURCE, tag, comm, status, ierr) 
136 !
137          if (status(MPI_SOURCE) .ne. next) then
138             print *, 'Rsend: Incorrect source, expected', next, &
139       &               ', got', status(MPI_SOURCE)
140             errs = errs + 1
141          end if
142 !
143          if (status(MPI_TAG) .ne. tag) then
144             print *, 'Rsend: Incorrect tag, expected', tag, &
145       &               ', got', status(MPI_TAG)
146             errs = errs + 1
147          end if
148 !
149          call MPI_Get_count(status, MPI_REAL, i, ierr)
150 !
151          if (i .ne. count) then
152             print *, 'Rsend: Incorrect count, expected', count, &
153       &               ', got', i
154             errs = errs + 1
155          end if
156 !
157          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
158       &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm,  &
159       &                 status, ierr)
160 !
161          call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
162       &                   'rsend and recv', errs )
163 !
164       else if (prev .eq. 0) then
165 !
166          call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
167       &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
168       &                 requests(1), ierr)
169          call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag,  &
170       &                  comm, ierr )
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 )
174 !
175          call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
176       &                  comm, ierr) 
177       end if
178 !
179       end
180 !
181       subroutine test_pair_ssend( comm, errs )
182       use mpi
183       integer comm, errs
184       integer rank, size, ierr, next, prev, tag, count, i
185       integer TEST_SIZE
186       parameter (TEST_SIZE=2000)
187       integer status(MPI_STATUS_SIZE)
188       logical flag
189       real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
190       logical verbose
191       common /flags/ verbose
192 !
193       if (verbose) then
194          print *, ' Ssend and recv'
195       endif
196 !
197 !
198       call mpi_comm_rank( comm, rank, ierr )
199       call mpi_comm_size( comm, size, ierr )
200       next = rank + 1
201       if (next .ge. size) next = 0
202 !
203       prev = rank - 1
204       if (prev .lt. 0) prev = size - 1
205 !
206       tag = 1789
207       count = TEST_SIZE / 3
208 !
209       call clear_test_data(recv_buf,TEST_SIZE)
210 !
211       if (rank .eq. 0) then
212 !
213          call init_test_data(send_buf,TEST_SIZE)
214 !
215          call MPI_Iprobe(MPI_ANY_SOURCE, tag, &
216       &                   comm, flag, status, ierr) 
217 !
218          if (flag) then
219             print *, 'Ssend: Iprobe succeeded! source',  &
220       &               status(MPI_SOURCE), &
221       &               ', tag', status(MPI_TAG)
222             errs = errs + 1
223          end if
224 !
225          call MPI_Ssend(send_buf, count, MPI_REAL, next, tag, &
226       &                  comm, ierr) 
227 !
228          do while (.not. flag)
229             call MPI_Iprobe(MPI_ANY_SOURCE, tag, &
230       &                      comm, flag, status, ierr) 
231          end do
232 !           
233          if (status(MPI_SOURCE) .ne. next) then
234             print *, 'Ssend: Incorrect source, expected', next, &
235       &               ', got', status(MPI_SOURCE)
236             errs = errs + 1
237          end if
238 !
239          if (status(MPI_TAG) .ne. tag) then
240             print *, 'Ssend: Incorrect tag, expected', tag, &
241       &               ', got', status(MPI_TAG)
242             errs = errs + 1
243          end if
244 !
245          call MPI_Get_count(status, MPI_REAL, i, ierr)
246 !
247          if (i .ne. count) then
248             print *, 'Ssend: Incorrect count, expected', count, &
249       &               ', got', i
250             errs = errs + 1
251          end if
252 !
253          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
254       &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
255       &                 status, ierr)
256 !
257          call msg_check( recv_buf, next, tag, count, status, &
258       &        TEST_SIZE, 'ssend and recv', errs ) 
259 !
260       else if (prev .eq. 0) then
261 !
262          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
263       &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
264       &                 status, ierr)
265 !
266          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
267       &                   'ssend and recv', errs )
268 !
269          call MPI_Ssend(recv_buf, count, MPI_REAL, prev, tag, &
270       &                  comm, ierr) 
271       end if
272 !
273       end
274 !
275       subroutine test_pair_isend( comm, errs )
276       use mpi
277       integer comm, errs
278       integer rank, size, ierr, next, prev, tag, count
279       integer TEST_SIZE
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)
284       logical verbose
285       common /flags/ verbose
286 !
287       if (verbose) then
288          print *, ' isend and irecv'
289       endif
290 !
291 !
292       call mpi_comm_rank( comm, rank, ierr )
293       call mpi_comm_size( comm, size, ierr )
294       next = rank + 1
295       if (next .ge. size) next = 0
296 !
297       prev = rank - 1
298       if (prev .lt. 0) prev = size - 1
299 !
300       tag = 2123
301       count = TEST_SIZE / 5
302 !
303       call clear_test_data(recv_buf,TEST_SIZE)
304 !
305       if (rank .eq. 0) then
306 !
307          call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
308       &                  MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
309       &                  requests(1), ierr)
310 !
311          call init_test_data(send_buf,TEST_SIZE)
312 !
313          call MPI_Isend(send_buf, count, MPI_REAL, next, tag, &
314       &                  comm, requests(2), ierr) 
315 !
316          call MPI_Waitall(2, requests, statuses, ierr)
317 !
318          call rq_check( requests, 2, 'isend and irecv' )
319 !
320          call msg_check( recv_buf, next, tag, count, statuses(1,1), &
321       &        TEST_SIZE, 'isend and irecv', errs )
322 !
323       else if (prev .eq. 0) then
324 !
325          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
326       &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
327       &                 status, ierr)
328 !
329          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
330       &                   'isend and irecv', errs )
331 !
332          call MPI_Isend(recv_buf, count, MPI_REAL, prev, tag, &
333       &                  comm, requests(1), ierr) 
334 !
335          call MPI_Wait(requests(1), status, ierr)
336 !
337          call rq_check( requests(1), 1, 'isend and irecv' )
338 !
339       end if
340 !
341       end
342 !
343       subroutine test_pair_irsend( comm, errs )
344       use mpi
345       integer comm, errs
346       integer rank, size, ierr, next, prev, tag, count, index
347       integer TEST_SIZE
348       integer dupcom
349       parameter (TEST_SIZE=2000)
350       integer status(MPI_STATUS_SIZE), requests(2)
351       integer statuses(MPI_STATUS_SIZE,2)
352       logical flag
353       real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
354       logical verbose
355       common /flags/ verbose
356 !
357       if (verbose) then
358          print *, ' Irsend and irecv'
359       endif
360 !
361       call mpi_comm_rank( comm, rank, ierr )
362       call mpi_comm_size( comm, size, ierr )
363       next = rank + 1
364       if (next .ge. size) next = 0
365 !
366       prev = rank - 1
367       if (prev .lt. 0) prev = size - 1
368 !
369       call mpi_comm_dup( comm, dupcom, ierr )
370 !
371       tag = 2456
372       count = TEST_SIZE / 3
373 !
374       call clear_test_data(recv_buf,TEST_SIZE)
375 !
376       if (rank .eq. 0) then
377 !
378          call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
379       &                  MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
380       &                  requests(1), ierr)
381 !
382          call init_test_data(send_buf,TEST_SIZE)
383 !
384          call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0,  &
385       &                      MPI_BOTTOM, 0, MPI_INTEGER, next, 0,  &
386       &                      dupcom, status, ierr )
387 !
388          call MPI_Irsend(send_buf, count, MPI_REAL, next, tag, &
389       &                   comm, requests(2), ierr) 
390 !
391          index = -1
392          do while (index .ne. 1)
393             call MPI_Waitany(2, requests, index, statuses, ierr)
394          end do
395 !
396          call rq_check( requests(1), 1, 'irsend and irecv' )
397 !
398          call msg_check( recv_buf, next, tag, count, statuses, &
399       &           TEST_SIZE, 'irsend and irecv', errs )
400 !
401       else if (prev .eq. 0) then
402 !
403          call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
404       &                  MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
405       &                  requests(1), ierr)
406 !
407          call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, prev, 0,  &
408       &                      MPI_BOTTOM, 0, MPI_INTEGER, prev, 0,  &
409       &                      dupcom, status, ierr )
410 !
411          flag = .FALSE.
412          do while (.not. flag)
413             call MPI_Test(requests(1), flag, status, ierr)
414          end do
415 !
416          call rq_check( requests, 1, 'irsend and irecv (test)' )
417 !
418          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
419       &                   'irsend and irecv', errs )
420 !
421          call MPI_Irsend(recv_buf, count, MPI_REAL, prev, tag, &
422       &                   comm, requests(1), ierr) 
423 !
424          call MPI_Waitall(1, requests, statuses, ierr)
425 !
426          call rq_check( requests, 1, 'irsend and irecv' )
427 !
428       end if
429 !
430       call mpi_comm_free( dupcom, ierr )
431 !
432       end
433 !
434       subroutine test_pair_issend( comm, errs )
435       use mpi
436       integer comm, errs
437       integer rank, size, ierr, next, prev, tag, count, index
438       integer TEST_SIZE
439       parameter (TEST_SIZE=2000)
440       integer status(MPI_STATUS_SIZE), requests(2)
441       integer statuses(MPI_STATUS_SIZE,2)
442       logical flag
443       real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
444       logical verbose
445       common /flags/ verbose
446 !
447       if (verbose) then
448          print *, ' issend and irecv (testall)'
449       endif
450 !
451 !
452       call mpi_comm_rank( comm, rank, ierr )
453       call mpi_comm_size( comm, size, ierr )
454       next = rank + 1
455       if (next .ge. size) next = 0
456 !
457       prev = rank - 1
458       if (prev .lt. 0) prev = size - 1
459 !
460       tag = 2789
461       count = TEST_SIZE / 3
462 !
463       call clear_test_data(recv_buf,TEST_SIZE)
464 !
465       if (rank .eq. 0) then
466 !
467          call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL, &
468       &                  MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
469       &                  requests(1), ierr)
470 !
471          call init_test_data(send_buf,TEST_SIZE)
472 !
473          call MPI_Issend(send_buf, count, MPI_REAL, next, tag, &
474       &                   comm, requests(2), ierr) 
475 !
476          flag = .FALSE.
477          do while (.not. flag)
478             call MPI_Testall(2, requests, flag, statuses, ierr)
479          end do
480 !
481          call rq_check( requests, 2, 'issend and irecv (testall)' )
482 !
483          call msg_check( recv_buf, next, tag, count, statuses(1,1), &
484       &           TEST_SIZE, 'issend and recv (testall)', errs )
485 !
486       else if (prev .eq. 0) then
487 !
488          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
489       &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
490       &                 status, ierr)
491
492          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
493       &                   'issend and recv', errs )
494
495          call MPI_Issend(recv_buf, count, MPI_REAL, prev, tag, &
496       &                   comm, requests(1), ierr) 
497 !
498          flag = .FALSE.
499          do while (.not. flag)
500             call MPI_Testany(1, requests(1), index, flag, &
501       &                       statuses(1,1), ierr)
502          end do
503 !
504          call rq_check( requests, 1, 'issend and recv (testany)' )
505 !
506       end if
507 !
508       end
509 !
510       subroutine test_pair_psend( comm, errs )
511       use mpi
512       integer comm, errs
513       integer rank, size, ierr, next, prev, tag, count, i
514       integer TEST_SIZE
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)
519       logical verbose
520       common /flags/ verbose
521 !
522       if (verbose) then
523          print *, ' Persistent send and recv'
524       endif
525 !
526       call mpi_comm_rank( comm, rank, ierr )
527       call mpi_comm_size( comm, size, ierr )
528       next = rank + 1
529       if (next .ge. size) next = 0
530 !
531       prev = rank - 1
532       if (prev .lt. 0) prev = size - 1
533 !
534       tag = 3123
535       count = TEST_SIZE / 5
536 !
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, &
540       &                   requests(2), ierr)
541 !
542       if (rank .eq. 0) then
543 !
544          call init_test_data(send_buf,TEST_SIZE)
545 !
546          call MPI_Send_init(send_buf, count, MPI_REAL, next, tag, &
547       &                      comm, requests(1), ierr) 
548 !
549          call MPI_Startall(2, requests, ierr) 
550          call MPI_Waitall(2, requests, statuses, ierr)
551 !
552          call msg_check( recv_buf, next, tag, count, statuses(1,2), &
553       &        TEST_SIZE, 'persistent send/recv', errs )
554 !
555          call MPI_Request_free(requests(1), ierr)
556 !
557       else if (prev .eq. 0) then
558 !
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)
563 !
564          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
565       &                   'persistent send/recv', errs )
566 !
567          do i = 1,count
568             send_buf(i) = recv_buf(i)
569          end do
570 !
571          call MPI_Start(requests(1), ierr) 
572          call MPI_Wait(requests(1), status, ierr)
573 !
574          call MPI_Request_free(requests(1), ierr)
575       end if
576 !
577       call dummyRef( send_buf, count, ierr )
578       call MPI_Request_free(requests(2), ierr)
579 !
580       end
581 !
582       subroutine test_pair_prsend( comm, errs )
583       use mpi
584       integer comm, errs
585       integer rank, size, ierr, next, prev, tag, count, index, i
586       integer outcount, indices(2)
587       integer TEST_SIZE
588       parameter (TEST_SIZE=2000)
589       integer statuses(MPI_STATUS_SIZE,2), requests(2)
590       integer status(MPI_STATUS_SIZE)
591       logical flag
592       real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
593       logical verbose
594       common /flags/ verbose
595 !
596       if (verbose) then
597          print *, ' Persistent Rsend and recv'
598       endif
599 !
600       call mpi_comm_rank( comm, rank, ierr )
601       call mpi_comm_size( comm, size, ierr )
602       next = rank + 1
603       if (next .ge. size) next = 0
604 !
605       prev = rank - 1
606       if (prev .lt. 0) prev = size - 1
607 !
608       tag = 3456
609       count = TEST_SIZE / 3
610 !
611       call clear_test_data(recv_buf,TEST_SIZE)
612 !
613       call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, &
614       &                   MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
615       &                   requests(2), ierr)
616 !
617       if (rank .eq. 0) then
618 !
619          call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag, &
620       &                       comm, requests(1), ierr) 
621 !
622          call init_test_data(send_buf,TEST_SIZE)
623 !
624          call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,  &
625       &                  comm, status, ierr )
626 !
627          call MPI_Startall(2, requests, ierr)
628 !
629          index = -1
630 !
631          do while (index .ne. 2)
632             call MPI_Waitsome(2, requests, outcount, &
633       &                        indices, statuses, ierr)
634             do i = 1,outcount
635                if (indices(i) .eq. 2) then
636                   call msg_check( recv_buf, next, tag, count, &
637       &                 statuses(1,i), TEST_SIZE, 'waitsome', errs )
638                   index = 2
639                end if
640             end do
641          end do
642 !
643          call MPI_Request_free(requests(1), ierr)
644       else if (prev .eq. 0) then
645 !
646          call MPI_Rsend_init(send_buf, count, MPI_REAL, prev, tag, &
647       &                       comm, requests(1), ierr) 
648 !
649          call MPI_Start(requests(2), ierr)
650 !
651          call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, prev, tag,  &
652       &                  comm, ierr )
653 !
654          flag = .FALSE.
655          do while (.not. flag)
656             call MPI_Test(requests(2), flag, status, ierr)
657          end do
658          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
659       &                   'test', errs )
660 !
661          do i = 1,count
662             send_buf(i) = recv_buf(i)
663          end do
664 !
665          call MPI_Start(requests(1), ierr)
666          call MPI_Wait(requests(1), status, ierr)
667 !
668          call MPI_Request_free(requests(1), ierr)
669       end if
670 !
671       call dummyRef( send_buf, count, ierr )
672       call MPI_Request_free(requests(2), ierr)
673 !
674       end
675 !
676       subroutine test_pair_pssend( comm, errs )
677       use mpi
678       integer comm, errs
679       integer rank, size, ierr, next, prev, tag, count, index, i
680       integer outcount, indices(2)
681       integer TEST_SIZE
682       parameter (TEST_SIZE=2000)
683       integer statuses(MPI_STATUS_SIZE,2), requests(2)
684       integer status(MPI_STATUS_SIZE)
685       logical flag
686       real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
687       logical verbose
688       common /flags/ verbose
689 !
690       if (verbose) then
691          print *, ' Persistent Ssend and recv'
692       endif
693 !
694       call mpi_comm_rank( comm, rank, ierr )
695       call mpi_comm_size( comm, size, ierr )
696       next = rank + 1
697       if (next .ge. size) next = 0
698 !
699       prev = rank - 1
700       if (prev .lt. 0) prev = size - 1
701 !
702       tag = 3789
703       count = TEST_SIZE / 3
704 !
705       call clear_test_data(recv_buf,TEST_SIZE)
706 !
707       call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL, &
708       &                   MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
709       &                   requests(1), ierr)
710 !
711       if (rank .eq. 0) then
712 !
713          call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag, &
714       &                       comm, requests(2), ierr) 
715 !
716          call init_test_data(send_buf,TEST_SIZE)
717 !
718          call MPI_Startall(2, requests, ierr)
719 !
720          index = -1
721          do while (index .ne. 1)
722             call MPI_Testsome(2, requests, outcount, &
723       &                        indices, statuses, ierr)
724             do i = 1,outcount
725                if (indices(i) .eq. 1) then
726                   call msg_check( recv_buf, next, tag, count, &
727       &                 statuses(1,i), TEST_SIZE, 'testsome', errs )
728                   index = 1
729                end if
730             end do
731          end do
732 !
733          call MPI_Request_free(requests(2), ierr)
734 !
735       else if (prev .eq. 0) then
736 !
737          call MPI_Ssend_init(send_buf, count, MPI_REAL, prev, tag, &
738       &                       comm, requests(2), ierr) 
739 !
740          call MPI_Start(requests(1), ierr)
741 !
742          flag = .FALSE.
743          do while (.not. flag)
744             call MPI_Testany(1, requests(1), index, flag, &
745       &                       statuses(1,1), ierr)
746          end do
747          call msg_check( recv_buf, prev, tag, count, statuses(1,1), &
748       &           TEST_SIZE, 'testany', errs )
749
750          do i = 1,count
751             send_buf(i) = recv_buf(i)
752          end do
753 !
754          call MPI_Start(requests(2), ierr)
755          call MPI_Wait(requests(2), status, ierr)
756 !
757          call MPI_Request_free(requests(2), ierr)
758 !
759       end if
760 !
761       call dummyRef( send_buf, count, ierr )
762       call MPI_Request_free(requests(1), ierr)
763 !
764       end
765 !
766       subroutine test_pair_sendrecv( comm, errs )
767       use mpi
768       integer comm, errs
769       integer rank, size, ierr, next, prev, tag, count
770       integer TEST_SIZE
771       parameter (TEST_SIZE=2000)
772       integer status(MPI_STATUS_SIZE)
773       real send_buf(TEST_SIZE), recv_buf(TEST_SIZE)
774       logical verbose
775       common /flags/ verbose
776 !
777       if (verbose) then
778          print *, ' Sendrecv'
779       endif
780 !
781 !
782       call mpi_comm_rank( comm, rank, ierr )
783       call mpi_comm_size( comm, size, ierr )
784       next = rank + 1
785       if (next .ge. size) next = 0
786 !
787       prev = rank - 1
788       if (prev .lt. 0) prev = size - 1
789 !
790       tag = 4123
791       count = TEST_SIZE / 5
792
793       call clear_test_data(recv_buf,TEST_SIZE)
794
795       if (rank .eq. 0) then
796
797          call init_test_data(send_buf,TEST_SIZE)
798
799          call MPI_Sendrecv(send_buf, count, MPI_REAL, next, tag, &
800       &                     recv_buf, count, MPI_REAL, next, tag, &
801       &                     comm, status, ierr) 
802
803          call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
804       &                   'sendrecv', errs )
805
806       else if (prev .eq. 0) then
807
808          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
809       &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
810       &                 status, ierr)
811
812          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
813       &                   'recv/send', errs )
814
815          call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
816       &                 comm, ierr) 
817       end if
818 !
819       end
820 !
821       subroutine test_pair_sendrecvrepl( comm, errs )
822       use mpi
823       integer comm, errs
824       integer rank, size, ierr, next, prev, tag, count, i
825       integer TEST_SIZE
826       parameter (TEST_SIZE=2000)
827       integer status(MPI_STATUS_SIZE)
828       real recv_buf(TEST_SIZE)
829       logical verbose
830       common /flags/ verbose
831 !
832       if (verbose) then
833          print *, ' Sendrecv replace'
834       endif
835 !
836       call mpi_comm_rank( comm, rank, ierr )
837       call mpi_comm_size( comm, size, ierr )
838       next = rank + 1
839       if (next .ge. size) next = 0
840 !
841       prev = rank - 1
842       if (prev .lt. 0) prev = size - 1
843 !
844       tag = 4456
845       count = TEST_SIZE / 3
846
847       if (rank .eq. 0) then
848 !
849          call init_test_data(recv_buf, TEST_SIZE)
850 !
851          do 11 i = count+1,TEST_SIZE
852             recv_buf(i) = 0.0
853  11      continue
854 !
855          call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL, &
856       &                             next, tag, next, tag, &
857       &                             comm, status, ierr)  
858
859          call msg_check( recv_buf, next, tag, count, status, TEST_SIZE, &
860       &                   'sendrecvreplace', errs )
861
862       else if (prev .eq. 0) then
863
864          call clear_test_data(recv_buf,TEST_SIZE)
865
866          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL, &
867       &                 MPI_ANY_SOURCE, MPI_ANY_TAG, comm, &
868       &                 status, ierr)
869
870          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE, &
871       &                   'recv/send for replace', errs )
872
873          call MPI_Send(recv_buf, count, MPI_REAL, prev, tag, &
874       &                 comm, ierr) 
875       end if
876 !
877       end
878 !
879 !------------------------------------------------------------------------------
880 !
881 !  Check for correct source, tag, count, and data in test message.
882 !
883 !------------------------------------------------------------------------------
884       subroutine msg_check( recv_buf, source, tag, count, status, n,  &
885       &                      name, errs )
886       use mpi
887       integer n, errs
888       real    recv_buf(n)
889       integer source, tag, count, rank, status(MPI_STATUS_SIZE)
890       character*(*) name
891       logical foundError
892
893       integer ierr, recv_src, recv_tag, recv_count
894
895       foundError = .false.
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)
900
901       if (recv_src .ne. source) then
902          print *, '[', rank, '] Unexpected source:', recv_src,  &
903       &            ' in ', name
904          errs       = errs + 1
905          foundError = .true.
906       end if
907
908       if (recv_tag .ne. tag) then
909          print *, '[', rank, '] Unexpected tag:', recv_tag, ' in ', name
910          errs       = errs + 1
911          foundError = .true.
912       end if
913
914       if (recv_count .ne. count) then
915          print *, '[', rank, '] Unexpected count:', recv_count, &
916       &            ' in ', name
917          errs       = errs + 1
918          foundError = .true.
919       end if
920          
921       call verify_test_data(recv_buf, count, n, name, errs )
922
923       end
924 !------------------------------------------------------------------------------
925 !
926 !  Check that requests have been set to null
927 !
928 !------------------------------------------------------------------------------
929       subroutine rq_check( requests, n, msg )
930       use mpi
931       integer n, requests(n)
932       character*(*) msg
933       integer i
934 !
935       do 10 i=1, n
936          if (requests(i) .ne. MPI_REQUEST_NULL) then
937             print *, 'Nonnull request in ', msg
938          endif
939  10   continue
940 !      
941       end
942 !------------------------------------------------------------------------------
943 !
944 !  Initialize test data buffer with integral sequence.
945 !
946 !------------------------------------------------------------------------------
947       subroutine init_test_data(buf,n)
948       integer n
949       real buf(n)
950       integer i
951
952       do 10 i = 1, n
953          buf(i) = REAL(i)
954  10    continue
955       end
956
957 !------------------------------------------------------------------------------
958 !
959 !  Clear test data buffer
960 !
961 !------------------------------------------------------------------------------
962       subroutine clear_test_data(buf, n)
963       integer n
964       real buf(n)
965       integer i
966
967       do 10 i = 1, n
968          buf(i) = 0.
969  10   continue
970
971       end
972
973 !------------------------------------------------------------------------------
974 !
975 !  Verify test data buffer
976 !
977 !------------------------------------------------------------------------------
978       subroutine verify_test_data( buf, count, n, name, errs )
979       use mpi
980       integer n, errs
981       real buf(n)
982       character *(*) name
983       integer count, i
984 !
985       do 10 i = 1, count
986          if (buf(i) .ne. REAL(i)) then
987             print 100, buf(i), i, count, name
988             errs = errs + 1
989          endif
990  10   continue
991 !
992       do 20 i = count + 1, n
993          if (buf(i) .ne. 0.) then
994             print 100, buf(i), i, n, name
995             errs = errs + 1
996          endif
997  20   continue
998 !      
999 100   format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)
1000 !
1001       end
1002 !
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
1007 !    compiler.
1008 !
1009       subroutine dummyRef( a, n, ie )
1010       integer n, ie
1011       real    a(n)
1012 ! This condition will never be true, but the compile won't know that
1013       if (ie .eq. -1) then
1014           print *, a(n)
1015       endif
1016       return
1017       end