1 C -*- Mode: Fortran; -*-
3 C (C) 2011 by Argonne National Laboratory.
4 C See COPYRIGHT in top-level directory.
6 subroutine uop( cin, cout, count, datatype )
9 integer cin(*), cout(*)
10 integer count, datatype
14 if (datatype .ne. MPI_INTEGER) then
15 write(6,*) 'Invalid datatype ',datatype,
16 & ' passed to user_op()'
22 cout(i) = cin(i) + cout(i)
26 C Test of reduce scatter.
28 C Each processor contributes its rank + the index to the reduction,
29 C then receives the ith sum
31 C Can be called with any number of processors.
37 integer errs, ierr, toterr
39 parameter (maxsize=1024)
40 integer sendbuf(maxsize), recvbuf, recvcounts(maxsize)
41 integer size, rank, i, sumval
47 call mtest_init( ierr )
51 call mpi_comm_size( comm, size, ierr )
52 call mpi_comm_rank( comm, rank, ierr )
54 if (size .gt. maxsize) then
57 sendbuf(i) = rank + i - 1
61 call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts,
62 & MPI_INTEGER, MPI_SUM, comm, ierr )
64 sumval = size * rank + ((size - 1) * size)/2
65 C recvbuf should be size * (rank + i)
66 if (recvbuf .ne. sumval) then
68 print *, "Did not get expected value for reduce scatter"
69 print *, rank, " Got ", recvbuf, " expected ", sumval
72 call mpi_op_create( uop, .true., sumop, ierr )
73 call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts,
74 & MPI_INTEGER, sumop, comm, ierr )
76 sumval = size * rank + ((size - 1) * size)/2
77 C recvbuf should be size * (rank + i)
78 if (recvbuf .ne. sumval) then
80 print *, "sumop: Did not get expected value for reduce scatter"
81 print *, rank, " Got ", recvbuf, " expected ", sumval
83 call mpi_op_free( sumop, ierr )
85 call mtest_finalize( errs )
86 call mpi_finalize( ierr )