first commit to add the mpich-test suite to smpi tesh suite. Obviously all tests...

[simgrid.git] / teshsuite / smpi / mpich-test / coll / assocf.f

diff --git a/teshsuite/smpi/mpich-test/coll/assocf.f b/teshsuite/smpi/mpich-test/coll/assocf.f
new file mode 100644 (file)
index 0000000..f39747c
--- /dev/null
+++ b/teshsuite/smpi/mpich-test/coll/assocf.f
@@ -0,0 +1,73 @@
+C
+C Thanks to zollweg@tc.cornell.edu (John A. Zollweg) for this test 
+C which detected a problem in one version of the IBM product 
+C implementation of MPI.  The source of the problem in that implementation
+C was assuming that floating point arithmetic was associative (it isn't
+C even commutative on IBM hardware).
+C
+C This program was designed for IEEE and may be uninteresting on other
+C systems.  Note that since it is testing that the same VALUE is
+C delivered at each system, it will run correctly on all systems.
+C
+      PROGRAM ALLREDUCE
+      include 'mpif.h'
+      real*8 myval(4), sum, recvbuf(4)
+      integer ier, me, size, tsize, dtype, i, errors, toterr
+      data myval /-12830196119319614d0,9154042893114674d0,
+     &2371516219785616d0,1304637006419324.8d0/
+      call MPI_INIT(ier)
+      call MPI_COMM_SIZE(MPI_COMM_WORLD,size,ier)
+      if (size.ne.4) then
+         print *,"This test case must be run as a four-way job"
+         call MPI_FINALIZE(ier)
+         stop
+      end if   
+      call MPI_TYPE_SIZE( MPI_REAL, tsize, ier )
+      if (tsize .eq. 8) then
+         dtype = MPI_REAL
+      else 
+         call MPI_TYPE_SIZE( MPI_DOUBLE_PRECISION, tsize, ier )
+         if (tsize .ne. 8) then
+            print *, " Can not test allreduce without an 8 byte"
+            print *, " floating double type."
+            call MPI_FINALIZE(ier)
+            stop
+         endif
+         dtype = MPI_DOUBLE_PRECISION
+      endif
+      call MPI_COMM_RANK(MPI_COMM_WORLD,me,ier)
+      call MPI_ALLREDUCE(myval(me+1),sum,1,dtype,MPI_SUM,
+     &MPI_COMM_WORLD,ier)
+C
+C     collect the values and make sure that they are all the same BITWISE
+C     We could use Gather, but this gives us an added test.
+C
+      do 5 i=1,4
+         recvbuf(i) = i
+ 5    continue
+      call MPI_ALLGATHER( sum, 1, dtype, recvbuf, 1, dtype,
+     &                    MPI_COMM_WORLD, ier )
+      errors = 0
+      do 10 i=2,4
+C         print *, "recvbuf(",i,") = ", recvbuf(i), " on ", me
+         if (recvbuf(1) .ne. recvbuf(i)) then
+               errors = errors + 1
+               print *, "Inconsistent values for ", i, "th entry on ",
+     &                  me
+               print *, recvbuf(1), " not equal to ", recvbuf(i)
+          endif
+ 10   continue
+      call MPI_ALLREDUCE( errors, toterr, 1, MPI_INTEGER, MPI_SUM,
+     &                    MPI_COMM_WORLD, ier )
+      if (me .eq. 0) then
+         if (toterr .gt. 0) then
+            print *, " FAILED with ", toterr, " errors."
+         else
+            print *, " No Errors"
+         endif
+      endif
+C      print *," The value of the sum on node ",me,"is",sum
+      call MPI_FINALIZE(ier)
+C     Calling stop can generate unwanted noise on some systems, and is not
+C     required.
+      end