X-Git-Url: http://bilbo.iut-bm.univ-fcomte.fr/pub/gitweb/simgrid.git/blobdiff_plain/3f31053637ef02fcd96e3819683103686ce11992..9deda161a84a426d0ea75ec4bd9b8cdc3a4b28fb:/teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f

diff --git a/teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f b/teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f
new file mode 100644
index 0000000000..566d294b92
--- /dev/null
+++ b/teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f
@@ -0,0 +1,63 @@
+C -*- Mode: Fortran; -*- 
+C
+C  (C) 2003 by Argonne National Laboratory.
+C      See COPYRIGHT in top-level directory.
+C
+C
+C Test user-defined operations.  This tests a simple commutative operation
+C
+      subroutine uop( cin, cout, count, datatype )
+      implicit none
+      include 'mpif.h'
+      integer cin(*), cout(*)
+      integer count, datatype
+      integer i
+      
+C      if (datatype .ne. MPI_INTEGER) then
+C         print *, 'Invalid datatype (',datatype,') passed to user_op()'
+C         return
+C      endif
+
+      do i=1, count
+         cout(i) = cin(i) + cout(i)
+      enddo
+      end
+
+      program main
+      implicit none
+      include 'mpif.h'
+      external uop
+      integer ierr, errs
+      integer count, sumop, vin(65000), vout(65000), i, size
+      integer comm
+      
+      errs = 0
+
+      call mtest_init(ierr)
+      call mpi_op_create( uop, .true., sumop, ierr )
+
+      comm = MPI_COMM_WORLD
+      call mpi_comm_size( comm, size, ierr )
+      count = 1
+      do while (count .lt. 65000) 
+         do i=1, count
+            vin(i) = i
+            vout(i) = -1
+         enddo
+         call mpi_allreduce( vin, vout, count, MPI_INTEGER, sumop, 
+     *                       comm, ierr )
+C         Check that all results are correct
+         do i=1, count
+            if (vout(i) .ne. i * size) then
+               errs = errs + 1
+               if (errs .lt. 10) print *, "vout(",i,") = ", vout(i)
+            endif
+         enddo
+         count = count + count
+      enddo
+
+      call mpi_op_free( sumop, ierr )
+
+      call mtest_finalize(errs)
+      call mpi_finalize(ierr)
+      end