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