teshsuite/smpi/mpich3-test/f90/coll/uallreducef90.f90

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