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