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       subroutine user_op( invec, outvec, count, datatype )
  11       use mpi
  12       integer invec(*), outvec(*)
  13       integer count, datatype
  14       integer ii
  15
  16       if (datatype .ne. MPI_INTEGER) then
  17          write(6,*) 'Invalid datatype passed to user_op()'
  18          return
  19       endif
  20
  21       do ii=1, count
  22          outvec(ii) = invec(ii) * 2 + outvec(ii)
  23       enddo
  24
  25       end
  26
  27       program main
  28       use mpi
  29       integer max_buf_size
  30       parameter (max_buf_size=65000)
  31       integer vin(max_buf_size), vout(max_buf_size)
  32       external user_op
  33       integer ierr, errs
  34       integer count, myop
  35       integer ii
  36
  37       errs = 0
  38
  39       call mtest_init(ierr)
  40
  41       count = 0
  42       do while (count .le. max_buf_size )
  43          do ii = 1,count
  44             vin(ii) = ii
  45             vout(ii) = ii
  46          enddo
  47          call mpi_reduce_local( vin, vout, count, &
  48       &                          MPI_INTEGER, MPI_SUM, ierr )
  49 !        Check if the result is correct
  50          do ii = 1,count
  51             if ( vin(ii) .ne. ii ) then
  52                errs = errs + 1
  53             endif
  54             if ( vout(ii) .ne. 2*ii ) then
  55                errs = errs + 1
  56             endif
  57          enddo
  58          if ( count .gt. 0 ) then
  59             count = count + count
  60          else
  61             count = 1
  62          endif
  63       enddo
  64
  65       call mpi_op_create( user_op, .false., myop, ierr )
  66
  67       count = 0
  68       do while (count .le. max_buf_size)
  69          do ii = 1, count
  70             vin(ii) = ii
  71             vout(ii) = ii
  72          enddo
  73          call mpi_reduce_local( vin, vout, count, &
  74       &                          MPI_INTEGER, myop, ierr )
  75 !        Check if the result is correct
  76          do ii = 1, count
  77             if ( vin(ii) .ne. ii ) then
  78                errs = errs + 1
  79             endif
  80             if ( vout(ii) .ne. 3*ii ) then
  81                errs = errs + 1
  82             endif
  83          enddo
  84          if ( count .gt. 0 ) then
  85             count = count + count
  86          else
  87             count = 1
  88          endif
  89       enddo
  90
  91       call mpi_op_free( myop, ierr )
  92
  93       call mtest_finalize(errs)
  94       call mpi_finalize(ierr)
  95
  96       end