teshsuite/smpi/mpich-test/pt2pt/allpair2.f

   1 c
   2 c This program was inspired by a bug report from
   3 c fsset@corelli.lerc.nasa.gov (Scott Townsend)
   4 c The original version of this program was submitted by email to
   5 c mpi-bugs and is in the directory mpich/bugs/ssend (not distributed
   6 c with the distribution).  This program was modified by William
   7 c Gropp (to correct a few errors and make more consistent with the
   8 c structure of the test programs in the examples/test/pt2pt directory.
   9
  10 c A C version of this program is in allpairc.c
  11 c
  12 c This version is intended to test for memory leaks; it runs each test
  13 c a number of times (TEST_COUNT + some in test_pair).
  14 c
  15       program allpair2
  16       include 'mpif.h'
  17       integer ierr
  18
  19       call MPI_Init(ierr)
  20
  21       call test_pair
  22
  23       call MPI_Finalize(ierr)
  24
  25       end
  26
  27 c------------------------------------------------------------------------------
  28 c
  29 c  Simple pair communication exercises.
  30 c
  31 c------------------------------------------------------------------------------
  32       subroutine test_pair
  33       include 'mpif.h'
  34       integer TEST_SIZE, TEST_COUNT
  35       parameter (TEST_SIZE=2000)
  36       parameter (TEST_COUNT=100)
  37
  38       integer ierr, prev, next, count, tag, index, i, outcount,
  39      .        requests(2), indices(2), rank, size,
  40      .        status(MPI_STATUS_SIZE), statuses(MPI_STATUS_SIZE,2)
  41       integer dupcom
  42       integer c
  43       logical flag
  44       real send_buf( TEST_SIZE ), recv_buf ( TEST_SIZE )
  45
  46       call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
  47       call MPI_Comm_size( MPI_COMM_WORLD, size, ierr )
  48       call MPI_Comm_dup( MPI_COMM_WORLD, dupcom, ierr )
  49       next = rank + 1
  50       if (next .ge. size) next = 0
  51
  52       prev = rank - 1
  53       if (prev .lt. 0) prev = size - 1
  54 c
  55 c     Normal sends
  56 c
  57       if (rank .eq. 0) then
  58          print *, '    Send'
  59          end if
  60
  61       tag = 1123
  62       count = TEST_SIZE / 5
  63
  64       do 111 c=1, TEST_COUNT+1
  65
  66       call clear_test_data(recv_buf,TEST_SIZE)
  67
  68       if (rank .eq. 0) then
  69
  70          call init_test_data(send_buf,TEST_SIZE)
  71
  72          call MPI_Send(send_buf, count, MPI_REAL, next, tag,
  73      .                 MPI_COMM_WORLD, ierr)
  74
  75          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
  76      .                 MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
  77      .                 status, ierr)
  78
  79          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
  80      .                   'send and recv' )
  81
  82       else
  83
  84          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
  85      .                 MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
  86      .                 status, ierr)
  87
  88          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
  89      .                   'send and recv' )
  90
  91          call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
  92      .                 MPI_COMM_WORLD, ierr)
  93          end if
  94  111  continue
  95 c
  96 c     Ready sends.  Note that we must ensure that the receive is posted
  97 c     before the rsend; this requires using Irecv.
  98 c
  99       if (rank .eq. 0) then
 100          print *, '    Rsend'
 101          end if
 102
 103       tag = 1456
 104       count = TEST_SIZE / 3
 105
 106       do 112 c = 1, TEST_COUNT+2
 107       call clear_test_data(recv_buf,TEST_SIZE)
 108
 109       if (rank .eq. 0) then
 110
 111          call init_test_data(send_buf,TEST_SIZE)
 112
 113          call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
 114      .                  MPI_COMM_WORLD, status, ierr )
 115
 116          call MPI_Rsend(send_buf, count, MPI_REAL, next, tag,
 117      .                  MPI_COMM_WORLD, ierr)
 118
 119          call MPI_Probe(MPI_ANY_SOURCE, tag,
 120      .                  MPI_COMM_WORLD, status, ierr)
 121
 122          if (status(MPI_SOURCE) .ne. prev) then
 123             print *, 'Incorrect source, expected', prev,
 124      .               ', got', status(MPI_SOURCE)
 125             end if
 126
 127          if (status(MPI_TAG) .ne. tag) then
 128             print *, 'Incorrect tag, expected', tag,
 129      .               ', got', status(MPI_TAG)
 130             end if
 131
 132          call MPI_Get_count(status, MPI_REAL, i, ierr)
 133
 134          if (i .ne. count) then
 135             print *, 'Incorrect count, expected', count,
 136      .               ', got', i
 137             end if
 138
 139          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
 140      .                 MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 141      .                 status, ierr)
 142
 143          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 144      .                   'rsend and recv' )
 145
 146       else
 147
 148          call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
 149      .                 MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 150      .                 requests(1), ierr)
 151          call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, next, tag,
 152      .                  MPI_COMM_WORLD, ierr )
 153          call MPI_Wait( requests(1), status, ierr )
 154
 155          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 156      .                   'rsend and recv' )
 157
 158          call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
 159      .                  MPI_COMM_WORLD, ierr)
 160          end if
 161  112  continue
 162 c
 163 c     Synchronous sends
 164 c
 165       if (rank .eq. 0) then
 166          print *, '    Ssend'
 167          end if
 168
 169       tag = 1789
 170       count = TEST_SIZE / 3
 171
 172       do 113 c = 1, TEST_COUNT+3
 173       call clear_test_data(recv_buf,TEST_SIZE)
 174
 175       if (rank .eq. 0) then
 176
 177          call init_test_data(send_buf,TEST_SIZE)
 178
 179          call MPI_Iprobe(MPI_ANY_SOURCE, tag,
 180      .                   MPI_COMM_WORLD, flag, status, ierr)
 181
 182          if (flag) then
 183             print *, 'Iprobe succeeded! source', status(MPI_SOURCE),
 184      .               ', tag', status(MPI_TAG)
 185             end if
 186
 187          call MPI_Ssend(send_buf, count, MPI_REAL, next, tag,
 188      .                  MPI_COMM_WORLD, ierr)
 189
 190          do while (.not. flag)
 191             call MPI_Iprobe(MPI_ANY_SOURCE, tag,
 192      .                      MPI_COMM_WORLD, flag, status, ierr)
 193             end do
 194
 195          if (status(MPI_SOURCE) .ne. prev) then
 196             print *, 'Incorrect source, expected', prev,
 197      .               ', got', status(MPI_SOURCE)
 198             end if
 199
 200          if (status(MPI_TAG) .ne. tag) then
 201             print *, 'Incorrect tag, expected', tag,
 202      .               ', got', status(MPI_TAG)
 203             end if
 204
 205          call MPI_Get_count(status, MPI_REAL, i, ierr)
 206
 207          if (i .ne. count) then
 208             print *, 'Incorrect count, expected', count,
 209      .               ', got', i
 210             end if
 211
 212          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
 213      .                 MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 214      .                 status, ierr)
 215
 216          call msg_check( recv_buf, prev, tag, count, status,
 217      $        TEST_SIZE, 'ssend and recv' )
 218
 219       else
 220
 221          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
 222      .                 MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 223      .                 status, ierr)
 224
 225          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 226      .                   'ssend and recv' )
 227
 228          call MPI_Ssend(recv_buf, count, MPI_REAL, next, tag,
 229      .                  MPI_COMM_WORLD, ierr)
 230          end if
 231  113  continue
 232 c
 233 c     Nonblocking normal sends
 234 c
 235       if (rank .eq. 0) then
 236          print *, '    Isend'
 237          end if
 238
 239       tag = 2123
 240       count = TEST_SIZE / 5
 241
 242       do 114 c = 1, TEST_COUNT+4
 243       call clear_test_data(recv_buf,TEST_SIZE)
 244
 245       if (rank .eq. 0) then
 246
 247          call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
 248      .                  MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 249      .                  requests(1), ierr)
 250
 251          call init_test_data(send_buf,TEST_SIZE)
 252
 253          call MPI_Isend(send_buf, count, MPI_REAL, next, tag,
 254      .                  MPI_COMM_WORLD, requests(2), ierr)
 255
 256          call MPI_Waitall(2, requests, statuses, ierr)
 257
 258          call rq_check( requests, 2, 'isend and irecv' )
 259
 260          call msg_check( recv_buf, prev, tag, count, statuses(1,1),
 261      $        TEST_SIZE, 'isend and irecv' )
 262
 263       else
 264
 265          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
 266      .                 MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 267      .                 status, ierr)
 268
 269          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 270      .                   'isend and irecv' )
 271
 272          call MPI_Isend(recv_buf, count, MPI_REAL, next, tag,
 273      .                  MPI_COMM_WORLD, requests(1), ierr)
 274
 275          call MPI_Wait(requests(1), status, ierr)
 276
 277          call rq_check( requests(1), 1, 'isend and irecv' )
 278
 279          end if
 280  114  continue
 281 c
 282 c     Nonblocking ready sends
 283 c
 284       if (rank .eq. 0) then
 285          print *, '    Irsend'
 286          end if
 287
 288       tag = 2456
 289       count = TEST_SIZE / 3
 290
 291       do 115 c = 1, TEST_COUNT+5
 292       call clear_test_data(recv_buf,TEST_SIZE)
 293
 294       if (rank .eq. 0) then
 295
 296          call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
 297      .                  MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 298      .                  requests(1), ierr)
 299
 300          call init_test_data(send_buf,TEST_SIZE)
 301
 302          call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
 303      .                      MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
 304      .                      dupcom, status, ierr )
 305
 306          call MPI_Irsend(send_buf, count, MPI_REAL, next, tag,
 307      .                   MPI_COMM_WORLD, requests(2), ierr)
 308
 309          index = -1
 310          do while (index .ne. 1)
 311             call MPI_Waitany(2, requests, index, statuses, ierr)
 312             end do
 313
 314          call rq_check( requests(1), 1, 'irsend and irecv' )
 315
 316          call msg_check( recv_buf, prev, tag, count, statuses,
 317      $           TEST_SIZE, 'irsend and irecv' )
 318
 319 C
 320 C        In case the send didn't complete yet.
 321          call MPI_Waitall( 2, requests, statuses, ierr )
 322
 323       else
 324
 325          call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
 326      .                  MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 327      .                  requests(1), ierr)
 328
 329          call MPI_Sendrecv( MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
 330      .                      MPI_BOTTOM, 0, MPI_INTEGER, next, 0,
 331      .                      dupcom, status, ierr )
 332
 333          flag = .FALSE.
 334          do while (.not. flag)
 335             call MPI_Test(requests(1), flag, status, ierr)
 336             end do
 337
 338          call rq_check( requests, 1, 'irsend and irecv (test)' )
 339
 340          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 341      .                   'irsend and irecv' )
 342
 343          call MPI_Irsend(recv_buf, count, MPI_REAL, next, tag,
 344      .                   MPI_COMM_WORLD, requests(1), ierr)
 345
 346          call MPI_Waitall(1, requests, statuses, ierr)
 347
 348          call rq_check( requests, 1, 'irsend and irecv' )
 349
 350          end if
 351  115  continue
 352 c
 353 c     Nonblocking synchronous sends
 354 c
 355       if (rank .eq. 0) then
 356          print *, '    Issend'
 357          end if
 358
 359       tag = 2789
 360       count = TEST_SIZE / 3
 361
 362       do 116 c = 1, TEST_COUNT+6
 363       call clear_test_data(recv_buf,TEST_SIZE)
 364
 365       if (rank .eq. 0) then
 366
 367          call MPI_Irecv(recv_buf, TEST_SIZE, MPI_REAL,
 368      .                  MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 369      .                  requests(1), ierr)
 370
 371          call init_test_data(send_buf,TEST_SIZE)
 372
 373          call MPI_Issend(send_buf, count, MPI_REAL, next, tag,
 374      .                   MPI_COMM_WORLD, requests(2), ierr)
 375
 376          flag = .FALSE.
 377          do while (.not. flag)
 378             call MPI_Testall(2, requests, flag, statuses, ierr)
 379 C            print *, 'flag = ', flag
 380             end do
 381
 382          call rq_check( requests, 2, 'issend and irecv (testall)' )
 383
 384          call msg_check( recv_buf, prev, tag, count, statuses(1,1),
 385      $           TEST_SIZE, 'issend and recv (testall)' )
 386
 387       else
 388
 389          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
 390      .                 MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 391      .                 status, ierr)
 392
 393          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 394      .                   'issend and recv' )
 395
 396          call MPI_Issend(recv_buf, count, MPI_REAL, next, tag,
 397      .                   MPI_COMM_WORLD, requests(1), ierr)
 398
 399          flag = .FALSE.
 400          do while (.not. flag)
 401             call MPI_Testany(1, requests(1), index, flag,
 402      .                       statuses(1,1), ierr)
 403 c            print *, 'flag = ', flag
 404             end do
 405
 406          call rq_check( requests, 1, 'issend and recv (testany)' )
 407
 408          end if
 409  116  continue
 410 c
 411 c     Persistent normal sends
 412 c
 413       if (rank .eq. 0) then
 414          print *, '    Send_init'
 415          end if
 416
 417       tag = 3123
 418       count = TEST_SIZE / 5
 419
 420       do 117 c = 1, TEST_COUNT+7
 421       call clear_test_data(recv_buf,TEST_SIZE)
 422
 423       call MPI_Send_init(send_buf, count, MPI_REAL, next, tag,
 424      .                   MPI_COMM_WORLD, requests(1), ierr)
 425
 426       call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
 427      .                   MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 428      .                   requests(2), ierr)
 429
 430       if (rank .eq. 0) then
 431
 432          call init_test_data(send_buf,TEST_SIZE)
 433
 434          call MPI_Startall(2, requests, ierr)
 435          call MPI_Waitall(2, requests, statuses, ierr)
 436
 437          call msg_check( recv_buf, prev, tag, count, statuses(1,2),
 438      $        TEST_SIZE, 'persistent send/recv' )
 439
 440       else
 441
 442          call MPI_Start(requests(2), ierr)
 443          call MPI_Wait(requests(2), status, ierr)
 444
 445          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 446      *                   'persistent send/recv')
 447
 448          do i = 1,count
 449             send_buf(i) = recv_buf(i)
 450             end do
 451
 452          call MPI_Start(requests(1), ierr)
 453          call MPI_Wait(requests(1), status, ierr)
 454
 455          end if
 456
 457       call MPI_Request_free(requests(1), ierr)
 458       call MPI_Request_free(requests(2), ierr)
 459  117  continue
 460 c
 461 c     Persistent ready sends
 462 c     Like the ready send, we must ensure that the receive is posted
 463 c     before the ready send is started.
 464 c
 465       if (rank .eq. 0) then
 466          print *, '    Rsend_init'
 467          end if
 468
 469       tag = 3456
 470       count = TEST_SIZE / 3
 471
 472       do 118 c = 1, TEST_COUNT+8
 473       call clear_test_data(recv_buf,TEST_SIZE)
 474
 475       call MPI_Rsend_init(send_buf, count, MPI_REAL, next, tag,
 476      .                    MPI_COMM_WORLD, requests(1), ierr)
 477
 478       call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
 479      .                   MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 480      .                   requests(2), ierr)
 481
 482 c
 483 c receive a clear-to-go from the destination, so that the ready send
 484 c will find the matching receive when it arrives
 485
 486       if (rank .eq. 0) then
 487
 488          call init_test_data(send_buf,TEST_SIZE)
 489
 490          call MPI_Recv( MPI_BOTTOM, 0, MPI_INTEGER, 1, 321,
 491      $                  MPI_COMM_WORLD, status, ierr )
 492          call MPI_Startall(2, requests, ierr)
 493
 494          index = -1
 495          do while (index .ne. 2)
 496             call MPI_Waitsome(2, requests, outcount,
 497      .                        indices, statuses, ierr)
 498             do i = 1,outcount
 499                if (indices(i) .eq. 2) then
 500                   call msg_check( recv_buf, prev, tag, count,
 501      $                 statuses(1,i), TEST_SIZE, 'waitsome' )
 502                   index = 2
 503                   end if
 504                end do
 505             end do
 506
 507       else
 508
 509          call MPI_Start(requests(2), ierr)
 510
 511 c Let the target know that is may begin the ready send
 512          call MPI_Send( MPI_BOTTOM, 0, MPI_INTEGER, 0, 321,
 513      $                  MPI_COMM_WORLD, ierr )
 514
 515          flag = .FALSE.
 516          do while (.not. flag)
 517             call MPI_Test(requests(2), flag, status, ierr)
 518             end do
 519
 520          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 521      *                   'test' )
 522
 523          do i = 1,count
 524             send_buf(i) = recv_buf(i)
 525             end do
 526
 527          call MPI_Start(requests(1), ierr)
 528          call MPI_Wait(requests(1), status, ierr)
 529
 530          end if
 531
 532       call MPI_Request_free(requests(1), ierr)
 533       call MPI_Request_free(requests(2), ierr)
 534  118  continue
 535 c
 536 c     Persistent synchronous sends
 537 c
 538       if (rank .eq. 0) then
 539          print *, '    Ssend_init'
 540          end if
 541
 542       tag = 3789
 543       count = TEST_SIZE / 3
 544
 545       do 119 c = 1, TEST_COUNT+9
 546       call clear_test_data(recv_buf,TEST_SIZE)
 547
 548       call MPI_Ssend_init(send_buf, count, MPI_REAL, next, tag,
 549      .                    MPI_COMM_WORLD, requests(2), ierr)
 550
 551       call MPI_Recv_init(recv_buf, TEST_SIZE, MPI_REAL,
 552      .                   MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 553      .                   requests(1), ierr)
 554
 555       if (rank .eq. 0) then
 556
 557          call init_test_data(send_buf,TEST_SIZE)
 558
 559          call MPI_Startall(2, requests, ierr)
 560
 561          index = -1
 562          do while (index .ne. 1)
 563             call MPI_Testsome(2, requests, outcount,
 564      .                        indices, statuses, ierr)
 565             do i = 1,outcount
 566                if (indices(i) .eq. 1) then
 567                   call msg_check( recv_buf, prev, tag, count,
 568      $                 statuses(1,i), TEST_SIZE, 'testsome' )
 569                   index = 1
 570                   end if
 571                end do
 572             end do
 573
 574       else
 575
 576          call MPI_Start(requests(1), ierr)
 577
 578          flag = .FALSE.
 579          do while (.not. flag)
 580             call MPI_Testany(1, requests(1), index, flag,
 581      .                       statuses(1,1), ierr)
 582             end do
 583
 584          call msg_check( recv_buf, prev, tag, count, statuses(1,1),
 585      $           TEST_SIZE, 'testany' )
 586
 587          do i = 1,count
 588             send_buf(i) = recv_buf(i)
 589             end do
 590
 591          call MPI_Start(requests(2), ierr)
 592          call MPI_Wait(requests(2), status, ierr)
 593
 594          end if
 595
 596       call MPI_Request_free(requests(1), ierr)
 597       call MPI_Request_free(requests(2), ierr)
 598  119  continue
 599 c
 600 c     Send/receive.
 601 c
 602       if (rank .eq. 0) then
 603          print *, '    Sendrecv'
 604          end if
 605
 606       tag = 4123
 607       count = TEST_SIZE / 5
 608
 609       do 120 c = 1, TEST_COUNT+10
 610       call clear_test_data(recv_buf,TEST_SIZE)
 611
 612       if (rank .eq. 0) then
 613
 614          call init_test_data(send_buf,TEST_SIZE)
 615
 616          call MPI_Sendrecv(send_buf, count, MPI_REAL, next, tag,
 617      .                     recv_buf, count, MPI_REAL, prev, tag,
 618      .                     MPI_COMM_WORLD, status, ierr)
 619
 620          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 621      .                   'sendrecv' )
 622
 623       else
 624
 625          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
 626      .                 MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 627      .                 status, ierr)
 628
 629          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 630      .                   'recv/send' )
 631
 632          call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
 633      .                 MPI_COMM_WORLD, ierr)
 634          end if
 635  120  continue
 636 c
 637 c     Send/receive replace.
 638 c
 639       if (rank .eq. 0) then
 640          print *, '    Sendrecv_replace'
 641          end if
 642
 643       tag = 4456
 644       count = TEST_SIZE / 3
 645
 646       do 121 c = 1, TEST_COUNT+11
 647       if (rank .eq. 0) then
 648
 649          call init_test_data(recv_buf, TEST_SIZE)
 650
 651          do 11 i = count+1,TEST_SIZE
 652             recv_buf(i) = 0.0
 653  11      continue
 654
 655          call MPI_Sendrecv_replace(recv_buf, count, MPI_REAL,
 656      .                             next, tag, prev, tag,
 657      .                             MPI_COMM_WORLD, status, ierr)
 658
 659          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 660      .                   'sendrecvreplace' )
 661
 662       else
 663
 664          call clear_test_data(recv_buf,TEST_SIZE)
 665
 666          call MPI_Recv(recv_buf, TEST_SIZE, MPI_REAL,
 667      .                 MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD,
 668      .                 status, ierr)
 669
 670          call msg_check( recv_buf, prev, tag, count, status, TEST_SIZE,
 671      .                   'recv/send for replace' )
 672
 673          call MPI_Send(recv_buf, count, MPI_REAL, next, tag,
 674      .                 MPI_COMM_WORLD, ierr)
 675          end if
 676
 677  121  continue
 678
 679       call MPI_Comm_free( dupcom, ierr )
 680       return
 681
 682       end
 683
 684 c------------------------------------------------------------------------------
 685 c
 686 c  Check for correct source, tag, count, and data in test message.
 687 c
 688 c------------------------------------------------------------------------------
 689       subroutine msg_check( recv_buf, source, tag, count, status, n,
 690      *                      name )
 691       include 'mpif.h'
 692       integer n
 693       real    recv_buf(n)
 694       integer source, tag, count, rank, status(MPI_STATUS_SIZE)
 695       character*(*) name
 696
 697       integer ierr, recv_src, recv_tag, recv_count
 698
 699       recv_src = status(MPI_SOURCE)
 700       recv_tag = status(MPI_TAG)
 701       call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
 702       call MPI_Get_count(status, MPI_REAL, recv_count, ierr)
 703
 704 C     Check for null status
 705       if (recv_src .eq. MPI_ANY_SOURCE .and.
 706      *    recv_tag .eq. MPI_ANY_TAG .and.
 707      *    status(MPI_ERROR) .eq. MPI_SUCCESS) then
 708          print *, '[', rank, '] Unexpected NULL status in ', name
 709          call MPI_Abort( MPI_COMM_WORLD, 104, ierr )
 710       end if
 711       if (recv_src .ne. source) then
 712          print *, '[', rank, '] Unexpected source:', recv_src,
 713      *            ' in ', name
 714          call MPI_Abort(MPI_COMM_WORLD, 101, ierr)
 715          end if
 716
 717       if (recv_tag .ne. tag) then
 718          print *, '[', rank, '] Unexpected tag:', recv_tag, ' in ', name
 719          call MPI_Abort(MPI_COMM_WORLD, 102, ierr)
 720          end if
 721
 722       if (recv_count .ne. count) then
 723          print *, '[', rank, '] Unexpected count:', recv_count,
 724      *            ' in ', name
 725          call MPI_Abort(MPI_COMM_WORLD, 103, ierr)
 726          end if
 727
 728       call verify_test_data(recv_buf, count, n, name )
 729
 730       end
 731 c------------------------------------------------------------------------------
 732 c
 733 c  Check that requests have been set to null
 734 c
 735 c------------------------------------------------------------------------------
 736       subroutine rq_check( requests, n, msg )
 737       include 'mpif.h'
 738       integer n, requests(n)
 739       character*(*) msg
 740       integer i
 741 c
 742       do 10 i=1, n
 743          if (requests(i) .ne. MPI_REQUEST_NULL) then
 744             print *, 'Nonnull request in ', msg
 745          endif
 746  10   continue
 747 c
 748       end
 749 c------------------------------------------------------------------------------
 750 c
 751 c  Initialize test data buffer with integral sequence.
 752 c
 753 c------------------------------------------------------------------------------
 754       subroutine init_test_data(buf,n)
 755       integer n
 756       real buf(n)
 757       integer i
 758
 759       do 10 i = 1, n
 760          buf(i) = REAL(i)
 761  10    continue
 762       end
 763
 764 c------------------------------------------------------------------------------
 765 c
 766 c  Clear test data buffer
 767 c
 768 c------------------------------------------------------------------------------
 769       subroutine clear_test_data(buf, n)
 770       integer n
 771       real buf(n)
 772       integer i
 773
 774       do 10 i = 1, n
 775          buf(i) = 0.
 776  10   continue
 777
 778       end
 779
 780 c------------------------------------------------------------------------------
 781 c
 782 c  Verify test data buffer
 783 c
 784 c------------------------------------------------------------------------------
 785       subroutine verify_test_data(buf, count, n, name)
 786       include 'mpif.h'
 787       integer n
 788       real buf(n)
 789       character *(*) name
 790
 791       integer count, ierr, i
 792
 793       do 10 i = 1, count
 794          if (buf(i) .ne. REAL(i)) then
 795             print 100, buf(i), i, count, name
 796             call MPI_Abort(MPI_COMM_WORLD, 108, ierr)
 797             endif
 798  10       continue
 799
 800       do 20 i = count + 1, n
 801          if (buf(i) .ne. 0.) then
 802             print 100, buf(i), i, n, name
 803             call MPI_Abort(MPI_COMM_WORLD, 109, ierr)
 804             endif
 805  20       continue
 806
 807 100   format('Invalid data', f6.1, ' at ', i4, ' of ', i4, ' in ', a)
 808
 809       end