1 ! This file created from test/mpi/f77/coll/redscatf.f with f77tof90
2 ! -*- Mode: Fortran; -*-
4 ! (C) 2011 by Argonne National Laboratory.
5 ! See COPYRIGHT in top-level directory.
7 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,' passed to user_op()'
21 cout(i) = cin(i) + cout(i)
25 ! Test of reduce scatter.
27 ! Each processor contributes its rank + the index to the reduction,
28 ! then receives the ith sum
30 ! Can be called with any number of processors.
37 parameter (maxsize=1024)
39 integer size, rank, i, sumval
43 integer, dimension(:),allocatable :: sendbuf,recvcounts
44 ALLOCATE(sendbuf(maxsize), STAT=status)
45 ALLOCATE(recvcounts(maxsize), STAT=status)
48 call mtest_init( ierr )
52 call mpi_comm_size( comm, size, ierr )
53 call mpi_comm_rank( comm, rank, ierr )
55 if (size .gt. maxsize) then
58 sendbuf(i) = rank + i - 1
62 call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts, &
63 & MPI_INTEGER, MPI_SUM, comm, ierr )
65 sumval = size * rank + ((size - 1) * size)/2
66 ! recvbuf should be size * (rank + i)
67 if (recvbuf .ne. sumval) then
69 print *, "Did not get expected value for reduce scatter"
70 print *, rank, " Got ", recvbuf, " expected ", sumval
73 call mpi_op_create( uop, .true., sumop, ierr )
74 call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts, &
75 & MPI_INTEGER, sumop, comm, ierr )
77 sumval = size * rank + ((size - 1) * size)/2
78 ! recvbuf should be size * (rank + i)
79 if (recvbuf .ne. sumval) then
81 print *, "sumop: Did not get expected value for reduce scatter"
82 print *, rank, " Got ", recvbuf, " expected ", sumval
84 call mpi_op_free( sumop, ierr )
86 DEALLOCATE(recvcounts)
87 call mtest_finalize( errs )
88 call mpi_finalize( ierr )