teshsuite/smpi/mpich3-test/f77/coll/uallreducef.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2003 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   6 C
   7 C Test user-defined operations.  This tests a simple commutative operation
   8 C
   9       program main
  10       implicit none
  11       include 'mpif.h'
  12       external uop
  13       integer ierr, errs
  14       integer count, sumop, vin(65000), vout(65000), i, size
  15       integer comm
  16
  17       errs = 0
  18
  19       call mtest_init(ierr)
  20       call mpi_op_create( uop, .true., sumop, ierr )
  21
  22       comm = MPI_COMM_WORLD
  23       call mpi_comm_size( comm, size, ierr )
  24       count = 1
  25       do while (count .lt. 65000)
  26          do i=1, count
  27             vin(i) = i
  28             vout(i) = -1
  29          enddo
  30          call mpi_allreduce( vin, vout, count, MPI_INTEGER, sumop,
  31      *                       comm, ierr )
  32 C         Check that all results are correct
  33          do i=1, count
  34             if (vout(i) .ne. i * size) then
  35                errs = errs + 1
  36                if (errs .lt. 10) print *, "vout(",i,") = ", vout(i)
  37             endif
  38          enddo
  39          count = count + count
  40       enddo
  41
  42       call mpi_op_free( sumop, ierr )
  43
  44       call mtest_finalize(errs)
  45       call mpi_finalize(ierr)
  46       end
  47
  48       subroutine uop( cin, cout, count, datatype )
  49       implicit none
  50       include 'mpif.h'
  51       integer cin(*), cout(*)
  52       integer count, datatype
  53       integer i
  54
  55 C      if (datatype .ne. MPI_INTEGER) then
  56 C         print *, 'Invalid datatype (',datatype,') passed to user_op()'
  57 C         return
  58 C      endif
  59
  60       do i=1, count
  61          cout(i) = cin(i) + cout(i)
  62       enddo
  63       end