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

   1 C -*- Mode: Fortran; -*-
   2 C
   3 C  (C) 2011 by Argonne National Laboratory.
   4 C      See COPYRIGHT in top-level directory.
   5 C
   6 C Test of reduce scatter.
   7 C
   8 C Each processor contributes its rank + the index to the reduction,
   9 C then receives the ith sum
  10 C
  11 C Can be called with any number of processors.
  12 C
  13
  14       program main
  15       implicit none
  16       include 'mpif.h'
  17       integer errs, ierr, toterr
  18       integer maxsize
  19       parameter (maxsize=1024)
  20       integer sendbuf(maxsize), recvbuf, recvcounts(maxsize)
  21       integer size, rank, i, sumval
  22       integer comm, sumop
  23       external uop
  24
  25       errs = 0
  26
  27       call mtest_init( ierr )
  28
  29       comm = MPI_COMM_WORLD
  30
  31       call mpi_comm_size( comm, size, ierr )
  32       call mpi_comm_rank( comm, rank, ierr )
  33
  34       if (size .gt. maxsize) then
  35       endif
  36       do i=1, size
  37          sendbuf(i) = rank + i - 1
  38          recvcounts(i) = 1
  39       enddo
  40
  41       call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts,
  42      &     MPI_INTEGER, MPI_SUM, comm, ierr )
  43
  44       sumval = size * rank + ((size - 1) * size)/2
  45 C recvbuf should be size * (rank + i)
  46       if (recvbuf .ne. sumval) then
  47          errs = errs + 1
  48          print *, "Did not get expected value for reduce scatter"
  49          print *, rank, " Got ", recvbuf, " expected ", sumval
  50       endif
  51
  52       call mpi_op_create( uop, .true., sumop, ierr )
  53       call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts,
  54      &     MPI_INTEGER, sumop, comm, ierr )
  55
  56       sumval = size * rank + ((size - 1) * size)/2
  57 C recvbuf should be size * (rank + i)
  58       if (recvbuf .ne. sumval) then
  59          errs = errs + 1
  60          print *, "sumop: Did not get expected value for reduce scatter"
  61          print *, rank, " Got ", recvbuf, " expected ", sumval
  62       endif
  63       call mpi_op_free( sumop, ierr )
  64
  65       call mtest_finalize( errs )
  66       call mpi_finalize( ierr )
  67
  68       end
  69 C
  70       subroutine uop( cin, cout, count, datatype )
  71       implicit none
  72       include 'mpif.h'
  73       integer cin(*), cout(*)
  74       integer count, datatype
  75       integer i
  76
  77       if (.false.) then
  78          if (datatype .ne. MPI_INTEGER) then
  79             write(6,*) 'Invalid datatype ',datatype,
  80      &           ' passed to user_op()'
  81             return
  82          endif
  83       endif
  84
  85       do i=1, count
  86          cout(i) = cin(i) + cout(i)
  87       enddo
  88       end