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