Logo AND Algorithmique Numérique Distribuée

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