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 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
23      program main
24      implicit none
25      include 'mpif.h'
26      integer inbuf(2), outbuf(2)
27      integer ans, rank, size, comm
28      integer errs, ierr
29      integer sumop
30      external uop
31
32      errs = 0
33
34      call mtest_init( ierr )
35C
36C A simple test of exscan
37      comm = MPI_COMM_WORLD
38
39      call mpi_comm_rank( comm, rank, ierr )
40      call mpi_comm_size( comm, size, ierr )
41
42      inbuf(1) = rank
43      inbuf(2) = -rank
44      call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, MPI_SUM, comm,
45     &                 ierr )
46C this process has the sum of i from 0 to rank-1, which is
47C (rank)(rank-1)/2 and -i
48      ans = (rank * (rank - 1))/2
49      if (rank .gt. 0) then
50         if (outbuf(1) .ne. ans) then
51            errs = errs + 1
52            print *, rank, ' Expected ', ans, ' got ', outbuf(1)
53         endif
54         if (outbuf(2) .ne. -ans) then
55            errs = errs + 1
56            print *, rank, ' Expected ', -ans, ' got ', outbuf(1)
57         endif
58      endif
59C
60C Try a user-defined operation
61C
62      call mpi_op_create( uop, .true., sumop, ierr )
63      inbuf(1) = rank
64      inbuf(2) = -rank
65      call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,
66     &                 ierr )
67C this process has the sum of i from 0 to rank-1, which is
68C (rank)(rank-1)/2 and -i
69      ans = (rank * (rank - 1))/2
70      if (rank .gt. 0) then
71         if (outbuf(1) .ne. ans) then
72            errs = errs + 1
73            print *, rank, ' sumop: Expected ', ans, ' got ', outbuf(1)
74         endif
75         if (outbuf(2) .ne. -ans) then
76            errs = errs + 1
77            print *, rank, ' sumop: Expected ', -ans, ' got ', outbuf(1)
78         endif
79      endif
80      call mpi_op_free( sumop, ierr )
81
82C
83C Try a user-defined operation (and don't claim it is commutative)
84C
85      call mpi_op_create( uop, .false., sumop, ierr )
86      inbuf(1) = rank
87      inbuf(2) = -rank
88      call mpi_exscan( inbuf, outbuf, 2, MPI_INTEGER, sumop, comm,
89     &                 ierr )
90C this process has the sum of i from 0 to rank-1, which is
91C (rank)(rank-1)/2 and -i
92      ans = (rank * (rank - 1))/2
93      if (rank .gt. 0) then
94         if (outbuf(1) .ne. ans) then
95            errs = errs + 1
96            print *, rank, ' sumop2: Expected ', ans, ' got ', outbuf(1)
97         endif
98         if (outbuf(2) .ne. -ans) then
99            errs = errs + 1
100            print *, rank, ' sumop2: Expected ', -ans, ' got ',outbuf(1)
101         endif
102      endif
103      call mpi_op_free( sumop, ierr )
104
105      call mtest_finalize( errs )
106      end
107