Add (some) mpich3 f77 tests

[simgrid.git] / teshsuite / smpi / mpich3-test / f77 / coll / redscatf.f

diff --git a/teshsuite/smpi/mpich3-test/f77/coll/redscatf.f b/teshsuite/smpi/mpich3-test/f77/coll/redscatf.f
new file mode 100644 (file)
index 0000000..b19b1e7
--- /dev/null
+++ b/teshsuite/smpi/mpich3-test/f77/coll/redscatf.f
@@ -0,0 +1,85 @@
+C -*- Mode: Fortran; -*- 
+C
+C  (C) 2011 by Argonne National Laboratory.
+C      See COPYRIGHT in top-level directory.
+C
+      subroutine uop( cin, cout, count, datatype )
+      implicit none
+      include 'mpif.h'
+      integer cin(*), cout(*)
+      integer count, datatype
+      integer i
+      
+!      if (datatype .ne. MPI_INTEGER) then
+!         write(6,*) 'Invalid datatype ',datatype,' passed to user_op()'
+!         return
+!      endif
+
+      do i=1, count
+         cout(i) = cin(i) + cout(i)
+      enddo
+      end
+C
+C Test of reduce scatter.
+C
+C Each processor contributes its rank + the index to the reduction, 
+C then receives the ith sum
+C
+C Can be called with any number of processors.
+C
+
+      program main
+      implicit none
+      include 'mpif.h'
+      integer errs, ierr, toterr
+      integer maxsize
+      parameter (maxsize=1024)
+      integer sendbuf(maxsize), recvbuf, recvcounts(maxsize)
+      integer size, rank, i, sumval
+      integer comm, sumop
+      external uop
+
+      errs = 0
+
+      call mtest_init( ierr )
+
+      comm = MPI_COMM_WORLD
+
+      call mpi_comm_size( comm, size, ierr )
+      call mpi_comm_rank( comm, rank, ierr )
+
+      if (size .gt. maxsize) then
+      endif
+      do i=1, size
+         sendbuf(i) = rank + i - 1
+         recvcounts(i) = 1
+      enddo
+
+      call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts, 
+     &     MPI_INTEGER, MPI_SUM, comm, ierr )
+
+      sumval = size * rank + ((size - 1) * size)/2
+C recvbuf should be size * (rank + i) 
+      if (recvbuf .ne. sumval) then
+         errs = errs + 1
+         print *, "Did not get expected value for reduce scatter"
+         print *, rank, " Got ", recvbuf, " expected ", sumval
+      endif
+
+      call mpi_op_create( uop, .true., sumop, ierr )
+      call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts, 
+     &     MPI_INTEGER, sumop, comm, ierr )
+
+      sumval = size * rank + ((size - 1) * size)/2
+C recvbuf should be size * (rank + i) 
+      if (recvbuf .ne. sumval) then
+         errs = errs + 1
+         print *, "sumop: Did not get expected value for reduce scatter"
+         print *, rank, " Got ", recvbuf, " expected ", sumval
+      endif
+      call mpi_op_free( sumop, ierr )
+
+      call mtest_finalize( errs )
+      call mpi_finalize( ierr )
+
+      end