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