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
13 ! if (datatype .ne. MPI_INTEGER) then
14 ! write(6,*) 'Invalid datatype ',datatype,' passed to user_op()'
19 cout(i) = cin(i) + cout(i)
23 ! Test of reduce scatter.
25 ! Each processor contributes its rank + the index to the reduction,
26 ! then receives the ith sum
28 ! Can be called with any number of processors.
35 parameter (maxsize=1024)
37 integer size, rank, i, sumval
41 integer, dimension(:),allocatable :: sendbuf,recvcounts
42 ALLOCATE(sendbuf(maxsize), STAT=status)
43 ALLOCATE(recvcounts(maxsize), STAT=status)
46 call mtest_init( ierr )
50 call mpi_comm_size( comm, size, ierr )
51 call mpi_comm_rank( comm, rank, ierr )
53 if (size .gt. maxsize) then
56 sendbuf(i) = rank + i - 1
60 call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts, &
61 & MPI_INTEGER, MPI_SUM, comm, ierr )
63 sumval = size * rank + ((size - 1) * size)/2
64 ! recvbuf should be size * (rank + i)
65 if (recvbuf .ne. sumval) then
67 print *, "Did not get expected value for reduce scatter"
68 print *, rank, " Got ", recvbuf, " expected ", sumval
71 call mpi_op_create( uop, .true., sumop, ierr )
72 call mpi_reduce_scatter( sendbuf, recvbuf, recvcounts, &
73 & MPI_INTEGER, sumop, comm, ierr )
75 sumval = size * rank + ((size - 1) * size)/2
76 ! recvbuf should be size * (rank + i)
77 if (recvbuf .ne. sumval) then
79 print *, "sumop: Did not get expected value for reduce scatter"
80 print *, rank, " Got ", recvbuf, " expected ", sumval
82 call mpi_op_free( sumop, ierr )
84 DEALLOCATE(recvcounts)
85 call mtest_finalize( errs )
86 call mpi_finalize( ierr )