1C
2C Copyright (C) by Argonne National Laboratory
3C     See COPYRIGHT in top-level directory
4C
5
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
22C
23C Test of reduce scatter.
24C
25C Each processor contributes its rank + the index to the reduction,
26C then receives the ith sum
27C
28C Can be called with any number of processors.
29C
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
62C 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
74C 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
84      end
85