teshsuite/smpi/mpich3-test/f77/coll/reducelocalf.f

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2009 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   6 C
   7 C Test Fortran MPI_Reduce_local with MPI_OP_SUM and with user-defined operation.
   8 C
   9       subroutine user_op( invec, outvec, count, datatype )
  10       implicit none
  11       include 'mpif.h'
  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       implicit none
  29       include 'mpif.h'
  30       integer max_buf_size
  31       parameter (max_buf_size=65000)
  32       integer vin(max_buf_size), vout(max_buf_size)
  33       external user_op
  34       integer ierr, errs
  35       integer count, myop
  36       integer ii
  37
  38       errs = 0
  39
  40       call mtest_init(ierr)
  41
  42       count = 0
  43       do while (count .le. max_buf_size )
  44          do ii = 1,count
  45             vin(ii) = ii
  46             vout(ii) = ii
  47          enddo
  48          call mpi_reduce_local( vin, vout, count,
  49      &                          MPI_INTEGER, MPI_SUM, ierr )
  50 C        Check if the result is correct
  51          do ii = 1,count
  52             if ( vin(ii) .ne. ii ) then
  53                errs = errs + 1
  54             endif
  55             if ( vout(ii) .ne. 2*ii ) then
  56                errs = errs + 1
  57             endif
  58          enddo
  59          if ( count .gt. 0 ) then
  60             count = count + count
  61          else
  62             count = 1
  63          endif
  64       enddo
  65
  66       call mpi_op_create( user_op, .false., myop, ierr )
  67
  68       count = 0
  69       do while (count .le. max_buf_size)
  70          do ii = 1, count
  71             vin(ii) = ii
  72             vout(ii) = ii
  73          enddo
  74          call mpi_reduce_local( vin, vout, count,
  75      &                          MPI_INTEGER, myop, ierr )
  76 C        Check if the result is correct
  77          do ii = 1, count
  78             if ( vin(ii) .ne. ii ) then
  79                errs = errs + 1
  80             endif
  81             if ( vout(ii) .ne. 3*ii ) then
  82                errs = errs + 1
  83             endif
  84          enddo
  85          if ( count .gt. 0 ) then
  86             count = count + count
  87          else
  88             count = 1
  89          endif
  90       enddo
  91
  92       call mpi_op_free( myop, ierr )
  93
  94       call mtest_finalize(errs)
  95       call mpi_finalize(ierr)
  96
  97       end