Logo AND Algorithmique Numérique Distribuée

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