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       logical foundError
 903
 904       integer ierr, recv_src, recv_tag, recv_count
 905
 906       foundError = .false.
 907       recv_src = status(MPI_SOURCE)
 908       recv_tag = status(MPI_TAG)
 909       call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
 910       call MPI_Get_count(status, MPI_REAL, recv_count, ierr)
 911
 912       if (recv_src .ne. source) then
 913          print *, '[', rank, '] Unexpected source:', recv_src,
 914      *            ' in ', name
 915          errs       = errs + 1
 916          foundError = .true.
 917       end if
 918
 919       if (recv_tag .ne. tag) then
 920          print *, '[', rank, '] Unexpected tag:', recv_tag, ' in ', name
 921          errs       = errs + 1
 922          foundError = .true.
 923       end if
 924
 925       if (recv_count .ne. count) then
 926          print *, '[', rank, '] Unexpected count:', recv_count,
 927      *            ' in ', name
 928          errs       = errs + 1
 929          foundError = .true.
 930       end if
 931
 932       call verify_test_data(recv_buf, count, n, name, errs )
 933
 934       end
 935 c------------------------------------------------------------------------------
 936 c
 937 c  Check that requests have been set to null
 938 c
 939 c------------------------------------------------------------------------------
 940       subroutine rq_check( requests, n, msg )
 941       include 'mpif.h'
 942       integer n, requests(n)
 943       character*(*) msg
 944       integer i
 945 c
 946       do 10 i=1, n
 947          if (requests(i) .ne. MPI_REQUEST_NULL) then
 948             print *, 'Nonnull request in ', msg
 949          endif
 950  10   continue
 951 c
 952       end
 953 c------------------------------------------------------------------------------
 954 c
 955 c  Initialize test data buffer with integral sequence.
 956 c
 957 c------------------------------------------------------------------------------
 958       subroutine init_test_data(buf,n)
 959       integer n
 960       real buf(n)
 961       integer i
 962
 963       do 10 i = 1, n
 964          buf(i) = REAL(i)
 965  10    continue
 966       end
 967
 968 c------------------------------------------------------------------------------
 969 c
 970 c  Clear test data buffer
 971 c
 972 c------------------------------------------------------------------------------
 973       subroutine clear_test_data(buf, n)
 974       integer n
 975       real buf(n)
 976       integer i
 977
 978       do 10 i = 1, n
 979          buf(i) = 0.
 980  10   continue
 981
 982       end
 983
 984 c------------------------------------------------------------------------------
 985 c
 986 c  Verify test data buffer
 987 c
 988 c------------------------------------------------------------------------------
 989       subroutine verify_test_data( buf, count, n, name, errs )
 990       implicit none
 991       include 'mpif.h'
 992       integer n, errs
 993       real buf(n)
 994       character *(*) name
 995       integer count, ierr, i
 996 C
 997       do 10 i = 1, count
 998          if (buf(i) .ne. REAL(i)) then
 999             print 100, buf(i), i, count, name
1000             errs = errs + 1
1001          endif
1002  10   continue
1003 C
1004       do 20 i = count + 1, n
1005          if (buf(i) .ne. 0.) then
1006             print 100, buf(i), i, n, name
1007             errs = errs + 1
1008          endif
1009  20   continue
1010 C
1011 100   format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)
1012 C
1013       end
1014 C
1015 C    This routine is used to prevent the compiler from deallocating the
1016 C    array "a", which may happen in some of the tests (see the text in
1017 C    the MPI standard about why this may be a problem in valid Fortran
1018 C    codes).  Without this, for example, tests fail with the Cray ftn
1019 C    compiler.
1020 C
1021       subroutine dummyRef( a, n, ie )
1022       integer n, ie
1023       real    a(n)
1024 C This condition will never be true, but the compile won't know that
1025       if (ie .eq. -1) then
1026           print *, a(n)
1027       endif
1028       return
1029       end