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