1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
C
C Copyright (C) by Argonne National Laboratory
C See COPYRIGHT in top-level directory
C
C A simple test for Fortran support of the MPI_IN_PLACE value in Alltoall[vw].
C
program main
implicit none
include 'mpif.h'
integer SIZEOFINT
integer MAX_SIZE
parameter (MAX_SIZE=1024)
integer rbuf(MAX_SIZE)
integer sdispls(1), scounts(1), stypes(1)
integer rdispls(MAX_SIZE), rcounts(MAX_SIZE), rtypes(MAX_SIZE)
integer comm, rank, size, req
integer sumval, ierr, errs
integer iexpected, igot
integer i, j
errs = 0
call mtest_init( ierr )
comm = MPI_COMM_WORLD
call mpi_comm_rank( comm, rank, ierr )
call mpi_comm_size( comm, size, ierr )
call mpi_type_size( MPI_INTEGER, SIZEOFINT, ierr )
do i=1,MAX_SIZE
rbuf(i) = -1
enddo
do i=1,size
rbuf(i) = (i-1) * size + rank
enddo
call mpi_ialltoall( MPI_IN_PLACE, -1, MPI_DATATYPE_NULL,
. rbuf, 1, MPI_INTEGER, comm, req, ierr )
call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
do i=1,size
if (rbuf(i) .ne. (rank*size + i - 1)) then
errs = errs + 1
print *, '[', rank, ']: IALLTOALL rbuf(', i, ') = ',
. rbuf(i), ', should be', rank * size + i - 1
endif
enddo
do i=1,MAX_SIZE
rbuf(i) = -1
enddo
do i=1,size
rcounts(i) = i-1 + rank
rdispls(i) = (i-1) * (2*size)
do j=0,rcounts(i)-1
rbuf(rdispls(i)+j+1) = 100 * rank + 10 * (i-1) + j
enddo
enddo
sdispls(1) = 0
scounts(1) = 0
stypes(1) = MPI_DATATYPE_NULL
call mpi_ialltoallv( MPI_IN_PLACE, scounts, sdispls, stypes(1),
. rbuf, rcounts, rdispls, MPI_INTEGER,
. comm, req, ierr )
call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
do i=1,size
do j=0,rcounts(i)-1
iexpected = 100 * (i-1) + 10 * rank + j
igot = rbuf(rdispls(i)+j+1)
if ( igot .ne. iexpected ) then
errs = errs + 1
print *, '[', rank, ']: IALLTOALLV got ', igot,
. ',but expected ', iexpected,
. ' for block=', i-1, ' element=', j
endif
enddo
enddo
do i=1,MAX_SIZE
rbuf(i) = -1
enddo
do i=1,size
rcounts(i) = i-1 + rank
rdispls(i) = (i-1) * (2*size) * SIZEOFINT
rtypes(i) = MPI_INTEGER
do j=0,rcounts(i)-1
rbuf(rdispls(i)/SIZEOFINT+j+1) = 100 * rank
. + 10 * (i-1) + j
enddo
enddo
call mpi_ialltoallw( MPI_IN_PLACE, scounts, sdispls, stypes,
. rbuf, rcounts, rdispls, rtypes,
. comm, req, ierr )
call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
do i=1,size
do j=0,rcounts(i)-1
iexpected = 100 * (i-1) + 10 * rank + j
igot = rbuf(rdispls(i)/SIZEOFINT+j+1)
if ( igot .ne. iexpected ) then
errs = errs + 1
print *, '[', rank, ']: IALLTOALLW got ', igot,
. ',but expected ', iexpected,
. ' for block=', i-1, ' element=', j
endif
enddo
enddo
do i=1,MAX_SIZE
rbuf(i) = -1
enddo
do i = 1, size
rbuf(i) = rank + (i-1)
enddo
call mpi_ireduce_scatter_block( MPI_IN_PLACE, rbuf, 1,
. MPI_INTEGER, MPI_SUM, comm,
. req, ierr )
call mpi_wait( req, MPI_STATUS_IGNORE, ierr )
sumval = size * rank + ((size-1) * size)/2
if ( rbuf(1) .ne. sumval ) then
errs = errs + 1
print *, 'Ireduce_scatter_block does not get expected value.'
print *, '[', rank, ']:', 'Got ', rbuf(1), ' but expected ',
. sumval, '.'
endif
call mtest_finalize( errs )
end
|
