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

   1 ! This file created from test/mpi/f77/coll/reducelocalf.f with f77tof90
   2 ! -*- Mode: Fortran; -*-
   3 !
   4 !  (C) 2009 by Argonne National Laboratory.
   5 !      See COPYRIGHT in top-level directory.
   6 !
   7 !
   8 ! Test Fortran MPI_Reduce_local with MPI_OP_SUM and with user-defined operation.
   9 !
  10       program main
  11       use mpi
  12       integer max_buf_size
  13       parameter (max_buf_size=65000)
  14       integer vin(max_buf_size), vout(max_buf_size)
  15       external user_op
  16       integer ierr, errs
  17       integer count, myop
  18       integer ii
  19
  20       errs = 0
  21
  22       call mtest_init(ierr)
  23
  24       count = 0
  25       do while (count .le. max_buf_size )
  26          do ii = 1,count
  27             vin(ii) = ii
  28             vout(ii) = ii
  29          enddo
  30          call mpi_reduce_local( vin, vout, count, &
  31       &                          MPI_INTEGER, MPI_SUM, ierr )
  32 !        Check if the result is correct
  33          do ii = 1,count
  34             if ( vin(ii) .ne. ii ) then
  35                errs = errs + 1
  36             endif
  37             if ( vout(ii) .ne. 2*ii ) then
  38                errs = errs + 1
  39             endif
  40          enddo
  41          if ( count .gt. 0 ) then
  42             count = count + count
  43          else
  44             count = 1
  45          endif
  46       enddo
  47
  48       call mpi_op_create( user_op, .false., myop, ierr )
  49
  50       count = 0
  51       do while (count .le. max_buf_size)
  52          do ii = 1, count
  53             vin(ii) = ii
  54             vout(ii) = ii
  55          enddo
  56          call mpi_reduce_local( vin, vout, count, &
  57       &                          MPI_INTEGER, myop, ierr )
  58 !        Check if the result is correct
  59          do ii = 1, count
  60             if ( vin(ii) .ne. ii ) then
  61                errs = errs + 1
  62             endif
  63             if ( vout(ii) .ne. 3*ii ) then
  64                errs = errs + 1
  65             endif
  66          enddo
  67          if ( count .gt. 0 ) then
  68             count = count + count
  69          else
  70             count = 1
  71          endif
  72       enddo
  73
  74       call mpi_op_free( myop, ierr )
  75
  76       call mtest_finalize(errs)
  77       call mpi_finalize(ierr)
  78
  79       end
  80
  81       subroutine user_op( invec, outvec, count, datatype )
  82       use mpi
  83       integer invec(*), outvec(*)
  84       integer count, datatype
  85       integer ii
  86
  87       if (datatype .ne. MPI_INTEGER) then
  88          write(6,*) 'Invalid datatype passed to user_op()'
  89          return
  90       endif
  91
  92       do ii=1, count
  93          outvec(ii) = invec(ii) * 2 + outvec(ii)
  94       enddo
  95
  96       end