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