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

   1       program main
   2       include 'mpif.h'
   3       integer ierr, errs, toterrs
   4       integer request
   5       integer status(MPI_STATUS_SIZE)
   6       integer rank, size, buf(10)
   7       logical flag
   8 C
   9       call MPI_Init( ierr )
  10       errs = 0
  11 C
  12       call MPI_Comm_size( MPI_COMM_WORLD, size, ierr )
  13       if (size .lt. 2) then
  14          print *, 'Must have at least two processes'
  15          call MPI_Abort( MPI_COMM_WORLD, 1, ierr )
  16       endif
  17       call MPI_Comm_rank( MPI_COMM_WORLD, rank, ierr )
  18       if (rank .eq. 0) then
  19          do i = 1, 10
  20             buf(i) = i
  21          enddo
  22          call MPI_Isend( buf, 10, MPI_INTEGER, size - 1, 1,
  23      $        MPI_COMM_WORLD, request, ierr )
  24          call MPI_Wait( request, status, ierr )
  25       endif
  26       if (rank .eq. size - 1) then
  27          call MPI_Irecv( buf, 10, MPI_INTEGER, 0, 1, MPI_COMM_WORLD,
  28      $        request, ierr )
  29 C         call MPI_Wait( request, status, ierr )
  30          flag = .FALSE.
  31          do while (.not. flag)
  32             call MPI_Test( request, flag, status, ierr )
  33          enddo
  34 C
  35 C     Check the results
  36          do i = 1, 10
  37             if (buf(i) .ne. i) then
  38                errs = errs + 1
  39             endif
  40          enddo
  41       endif
  42 C
  43       call MPI_Allreduce( errs, toterrs, 1, MPI_INTEGER, MPI_SUM,
  44      $     MPI_COMM_WORLD, ierr )
  45       if (rank .eq. 0) then
  46          if (toterrs .gt. 0) then
  47             print *, "Found ", toterrs, " Errors"
  48          else
  49             PRINT *, " No Errors"
  50          endif
  51       endif
  52       call MPI_Finalize( ierr )
  53       end