1C
2C Copyright (C) by Argonne National Laboratory
3C     See COPYRIGHT in top-level directory
4C
5
6      program main
7      implicit none
8      include 'mpif.h'
9      integer ierr, errs
10      integer i, ans, size, rank, color, comm, newcomm
11      integer maxSize, displ
12      parameter (maxSize=128)
13      integer scounts(maxSize), sdispls(maxSize), stypes(maxSize)
14      integer rcounts(maxSize), rdispls(maxSize), rtypes(maxSize)
15      integer sbuf(maxSize), rbuf(maxSize)
16
17      errs = 0
18
19      call mtest_init( ierr )
20
21C Get a comm
22      call mpi_comm_dup( MPI_COMM_WORLD, comm, ierr )
23      call mpi_comm_size( comm, size, ierr )
24      if (size .gt. maxSize) then
25         call mpi_comm_rank( comm, rank, ierr )
26         color = 1
27         if (rank .lt. maxSize) color = 0
28         call mpi_comm_split( comm, color, rank, newcomm, ierr )
29         call mpi_comm_free( comm, ierr )
30         comm = newcomm
31         call mpi_comm_size( comm, size, ierr )
32      endif
33      call mpi_comm_rank( comm, rank, ierr )
34C
35      if (size .le. maxSize) then
36C Initialize the data.  Just use this as an all to all
37C Use the same test as alltoallwf.c , except displacements are in units of
38C integers instead of bytes
39         do i=1, size
40            scounts(i) = 1
41            sdispls(i) = (i-1)
42            stypes(i)  = MPI_INTEGER
43            sbuf(i) = rank * size + i
44            rcounts(i) = 1
45            rdispls(i) = (i-1)
46            rtypes(i)  = MPI_INTEGER
47            rbuf(i) = -1
48         enddo
49         call mpi_alltoallv( sbuf, scounts, sdispls, stypes,
50     &        rbuf, rcounts, rdispls, rtypes, comm, ierr )
51C
52C check rbuf(i) = data from the ith location of the ith send buf, or
53C       rbuf(i) = (i-1) * size + i
54         do i=1, size
55            ans = (i-1) * size + rank + 1
56            if (rbuf(i) .ne. ans) then
57               errs = errs + 1
58               print *, rank, ' rbuf(', i, ') = ', rbuf(i),
59     &               ' expected ', ans
60            endif
61         enddo
62C
63C     A halo-exchange example - mostly zero counts
64C
65         do i=1, size
66            scounts(i) = 0
67            sdispls(i) = 0
68            stypes(i)  = MPI_INTEGER
69            sbuf(i) = -1
70            rcounts(i) = 0
71            rdispls(i) = 0
72            rtypes(i)  = MPI_INTEGER
73            rbuf(i) = -1
74         enddo
75
76C
77C     Note that the arrays are 1-origin
78         displ = 0
79         if (rank .gt. 0) then
80            scounts(1+rank-1) = 1
81            rcounts(1+rank-1) = 1
82            sdispls(1+rank-1) = displ
83            rdispls(1+rank-1) = rank - 1
84            sbuf(1+displ)     = rank
85            displ             = displ + 1
86         endif
87         scounts(1+rank)   = 1
88         rcounts(1+rank)   = 1
89         sdispls(1+rank)   = displ
90         rdispls(1+rank)   = rank
91         sbuf(1+displ)     = rank
92         displ           = displ + 1
93         if (rank .lt. size-1) then
94            scounts(1+rank+1) = 1
95            rcounts(1+rank+1) = 1
96            sdispls(1+rank+1) = displ
97            rdispls(1+rank+1) = rank+1
98            sbuf(1+displ)     = rank
99            displ             = displ + 1
100         endif
101
102         call mpi_alltoallv( sbuf, scounts, sdispls, stypes,
103     &        rbuf, rcounts, rdispls, rtypes, comm, ierr )
104C
105C   Check the neighbor values are correctly moved
106C
107         if (rank .gt. 0) then
108            if (rbuf(1+rank-1) .ne. rank-1) then
109               errs = errs + 1
110               print *, rank, ' rbuf(',1+rank-1, ') = ', rbuf(1+rank-1),
111     &              'expected ', rank-1
112            endif
113         endif
114         if (rbuf(1+rank) .ne. rank) then
115            errs = errs + 1
116            print *, rank, ' rbuf(', 1+rank, ') = ', rbuf(1+rank),
117     &           'expected ', rank
118         endif
119         if (rank .lt. size-1) then
120            if (rbuf(1+rank+1) .ne. rank+1) then
121               errs = errs + 1
122               print *, rank, ' rbuf(', 1+rank+1, ') = ',rbuf(1+rank+1),
123     &              'expected ', rank+1
124            endif
125         endif
126         do i=0,rank-2
127            if (rbuf(1+i) .ne. -1) then
128               errs = errs + 1
129               print *, rank, ' rbuf(', 1+i, ') = ', rbuf(1+i),
130     &              'expected -1'
131            endif
132         enddo
133         do i=rank+2,size-1
134            if (rbuf(1+i) .ne. -1) then
135               errs = errs + 1
136               print *, rank, ' rbuf(', i, ') = ', rbuf(1+i),
137     &              'expected -1'
138            endif
139         enddo
140      endif
141      call mpi_comm_free( comm, ierr )
142
143      call mtest_finalize( errs )
144      end
145
146