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       subroutine uop( cin, cout, count, datatype )
  10       implicit none
  11       include 'mpif.h'
  12       integer cin(*), cout(*)
  13       integer count, datatype
  14       integer i
  15
  16 C      if (datatype .ne. MPI_INTEGER) then
  17 C         print *, 'Invalid datatype (',datatype,') passed to user_op()'
  18 C         return
  19 C      endif
  20
  21       do i=1, count
  22          cout(i) = cin(i) + cout(i)
  23       enddo
  24       end
  25
  26       program main
  27       implicit none
  28       include 'mpif.h'
  29       external uop
  30       integer ierr, errs
  31       integer count, sumop, vin(65000), vout(65000), i, size
  32       integer comm
  33
  34       errs = 0
  35
  36       call mtest_init(ierr)
  37       call mpi_op_create( uop, .true., sumop, ierr )
  38
  39       comm = MPI_COMM_WORLD
  40       call mpi_comm_size( comm, size, ierr )
  41       count = 1
  42       do while (count .lt. 65000)
  43          do i=1, count
  44             vin(i) = i
  45             vout(i) = -1
  46          enddo
  47          call mpi_allreduce( vin, vout, count, MPI_INTEGER, sumop,
  48      *                       comm, ierr )
  49 C         Check that all results are correct
  50          do i=1, count
  51             if (vout(i) .ne. i * size) then
  52                errs = errs + 1
  53                if (errs .lt. 10) print *, "vout(",i,") = ", vout(i)
  54             endif
  55          enddo
  56          count = count + count
  57       enddo
  58
  59       call mpi_op_free( sumop, ierr )
  60
  61       call mtest_finalize(errs)
  62       call mpi_finalize(ierr)
  63       end