1 ! This file created from test/mpi/f77/coll/alltoallvf.f with f77tof90
2 ! -*- Mode: Fortran; -*-
4 ! (C) 2011 by Argonne National Laboratory.
5 ! See COPYRIGHT in top-level directory.
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)
19 call mtest_init( ierr )
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 )
27 if (rank .lt. maxSize) color = 0
28 call mpi_comm_split( comm, color, rank, newcomm, ierr )
29 call mpi_comm_free( comm, ierr )
31 call mpi_comm_size( comm, size, ierr )
33 call mpi_comm_rank( comm, rank, ierr )
35 if (size .le. maxSize) then
36 ! Initialize the data. Just use this as an all to all
37 ! Use the same test as alltoallwf.c , except displacements are in units of
38 ! integers instead of bytes
42 stypes(i) = MPI_INTEGER
43 sbuf(i) = rank * size + i
46 rtypes(i) = MPI_INTEGER
49 call mpi_alltoallv( sbuf, scounts, sdispls, stypes, &
50 & rbuf, rcounts, rdispls, rtypes, comm, ierr )
52 ! check rbuf(i) = data from the ith location of the ith send buf, or
53 ! rbuf(i) = (i-1) * size + i
55 ans = (i-1) * size + rank + 1
56 if (rbuf(i) .ne. ans) then
58 print *, rank, ' rbuf(', i, ') = ', rbuf(i), &
63 ! A halo-exchange example - mostly zero counts
68 stypes(i) = MPI_INTEGER
72 rtypes(i) = MPI_INTEGER
77 ! Note that the arrays are 1-origin
82 sdispls(1+rank-1) = displ
83 rdispls(1+rank-1) = rank - 1
89 sdispls(1+rank) = displ
90 rdispls(1+rank) = rank
93 if (rank .lt. size-1) then
96 sdispls(1+rank+1) = displ
97 rdispls(1+rank+1) = rank+1
102 call mpi_alltoallv( sbuf, scounts, sdispls, stypes, &
103 & rbuf, rcounts, rdispls, rtypes, comm, ierr )
105 ! Check the neighbor values are correctly moved
107 if (rank .gt. 0) then
108 if (rbuf(1+rank-1) .ne. rank-1) then
110 print *, rank, ' rbuf(',1+rank-1, ') = ', rbuf(1+rank-1), &
111 & 'expected ', rank-1
114 if (rbuf(1+rank) .ne. rank) then
116 print *, rank, ' rbuf(', 1+rank, ') = ', rbuf(1+rank), &
119 if (rank .lt. size-1) then
120 if (rbuf(1+rank+1) .ne. rank+1) then
122 print *, rank, ' rbuf(', 1+rank+1, ') = ',rbuf(1+rank+1), &
123 & 'expected ', rank+1
127 if (rbuf(1+i) .ne. -1) then
129 print *, rank, ' rbuf(', 1+i, ') = ', rbuf(1+i), &
134 if (rbuf(1+i) .ne. -1) then
136 print *, rank, ' rbuf(', i, ') = ', rbuf(1+i), &
141 call mpi_comm_free( comm, ierr )
143 call mtest_finalize( errs )
144 call mpi_finalize( ierr )