teshsuite/smpi/mpich3-test/f90/pt2pt/allpairf90.f90

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