teshsuite/smpi/mpich-test/coll/assocf.f

   1 C
   2 C Thanks to zollweg@tc.cornell.edu (John A. Zollweg) for this test
   3 C which detected a problem in one version of the IBM product
   4 C implementation of MPI.  The source of the problem in that implementation
   5 C was assuming that floating point arithmetic was associative (it isn't
   6 C even commutative on IBM hardware).
   7 C
   8 C This program was designed for IEEE and may be uninteresting on other
   9 C systems.  Note that since it is testing that the same VALUE is
  10 C delivered at each system, it will run correctly on all systems.
  11 C
  12       PROGRAM ALLREDUCE
  13       include 'mpif.h'
  14       real*8 myval(4), sum, recvbuf(4)
  15       integer ier, me, size, tsize, dtype, i, errors, toterr
  16       data myval /-12830196119319614d0,9154042893114674d0,
  17      &2371516219785616d0,1304637006419324.8d0/
  18       call MPI_INIT(ier)
  19       call MPI_COMM_SIZE(MPI_COMM_WORLD,size,ier)
  20       if (size.ne.4) then
  21          print *,"This test case must be run as a four-way job"
  22          call MPI_FINALIZE(ier)
  23          stop
  24       end if
  25       call MPI_TYPE_SIZE( MPI_REAL, tsize, ier )
  26       if (tsize .eq. 8) then
  27          dtype = MPI_REAL
  28       else
  29          call MPI_TYPE_SIZE( MPI_DOUBLE_PRECISION, tsize, ier )
  30          if (tsize .ne. 8) then
  31             print *, " Can not test allreduce without an 8 byte"
  32             print *, " floating double type."
  33             call MPI_FINALIZE(ier)
  34             stop
  35          endif
  36          dtype = MPI_DOUBLE_PRECISION
  37       endif
  38       call MPI_COMM_RANK(MPI_COMM_WORLD,me,ier)
  39       call MPI_ALLREDUCE(myval(me+1),sum,1,dtype,MPI_SUM,
  40      &MPI_COMM_WORLD,ier)
  41 C
  42 C     collect the values and make sure that they are all the same BITWISE
  43 C     We could use Gather, but this gives us an added test.
  44 C
  45       do 5 i=1,4
  46          recvbuf(i) = i
  47  5    continue
  48       call MPI_ALLGATHER( sum, 1, dtype, recvbuf, 1, dtype,
  49      &                    MPI_COMM_WORLD, ier )
  50       errors = 0
  51       do 10 i=2,4
  52 C         print *, "recvbuf(",i,") = ", recvbuf(i), " on ", me
  53          if (recvbuf(1) .ne. recvbuf(i)) then
  54                errors = errors + 1
  55                print *, "Inconsistent values for ", i, "th entry on ",
  56      &                  me
  57                print *, recvbuf(1), " not equal to ", recvbuf(i)
  58           endif
  59  10   continue
  60       call MPI_ALLREDUCE( errors, toterr, 1, MPI_INTEGER, MPI_SUM,
  61      &                    MPI_COMM_WORLD, ier )
  62       if (me .eq. 0) then
  63          if (toterr .gt. 0) then
  64             print *, " FAILED with ", toterr, " errors."
  65          else
  66             print *, " No Errors"
  67          endif
  68       endif
  69 C      print *," The value of the sum on node ",me,"is",sum
  70       call MPI_FINALIZE(ier)
  71 C     Calling stop can generate unwanted noise on some systems, and is not
  72 C     required.
  73       end