1
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#include "fc_feature_defs.inc"
47PROGRAM test_redist_p2p_parallel
48 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
49 USE mpi
51 xt_int_kind, xi => xt_int_kind, &
58 USE test_idxlist_utils, ONLY: test_err_count
59 USE test_redist_common, ONLY: communicators_are_congruent, &
60 check_redist, redist_exchanger_option
61 IMPLICIT NONE
62
63 CHARACTER(len=*), PARAMETER :: filename = 'test_redist_p2p_parallel_f.f90'
64 TYPE(xt_config) :: config
65 INTEGER :: comm_rank, comm_size, ierror
66
67 CALL init_mpi
69 config = redist_exchanger_option()
70
71 CALL mpi_comm_rank(mpi_comm_world, comm_rank, ierror)
72 IF (ierror /= mpi_success) &
73 CALL test_abort("MPI error!", filename, __line__)
74
75 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
76 IF (ierror /= mpi_success) &
77 CALL test_abort("MPI error!", filename, __line__)
78
79 CALL simple_test
80 CALL nonuniform_test
81 CALL block_redist_test
82
83 IF (test_err_count() /= 0) &
84 CALL test_abort("non-zero error count!", filename, __line__)
87 CALL finish_mpi
88
89CONTAINS
90 SUBROUTINE simple_test
91 INTEGER, PARAMETER :: data_size = 10
92 INTEGER, PARAMETER :: src_num_indices = data_size, &
93 dst_num_indices = data_size
94 INTEGER(xt_int_kind) :: src_index_list(data_size), &
95 dst_index_list(data_size)
96 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
97 TYPE(xt_xmap) :: xmap
98 TYPE(xt_redist) :: redist
99 DOUBLE PRECISION :: src_data(data_size), dst_data(data_size)
100 INTEGER :: i
101
102
103 DO i = 1, src_num_indices
104 src_index_list(i) = int(comm_rank * data_size + (i - 1), xi)
105 END DO
106
108
109 DO i = 1, dst_num_indices
110 dst_index_list(i) &
111 = int(mod(comm_rank * data_size + i + 1, comm_size * data_size), xi)
112 END DO
114
116
118
119
120 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
121 mpi_comm_world)) &
122 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
123
124 DO i = 1, src_num_indices
125 src_data(i) = dble(comm_rank * data_size + i - 1)
126 END DO
127
128 CALL check_redist(redist, src_data, dst_data, dst_index_list)
129
130
135 END SUBROUTINE simple_test
136
137
138 SUBROUTINE nonuniform_test
139
140 INTEGER(xt_int_kind), ALLOCATABLE :: src_index_list(:), dst_index_list(:)
141 DOUBLE PRECISION, ALLOCATABLE :: src_data(:), dst_data(:), ref_dst_data(:)
142 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
143 TYPE(xt_xmap) :: xmap
144 TYPE(Xt_redist) :: redist
145 INTEGER :: i, src_num_indices, dst_num_indices
146
147 ALLOCATE(src_index_list(comm_size), dst_index_list(comm_size), &
148 src_data(comm_size), dst_data(comm_size), ref_dst_data(comm_size))
149 src_num_indices = merge(comm_size, 0, comm_rank == 0)
150 DO i = 1, src_num_indices
151 src_index_list(i) = int(i - 1, xi)
152 END DO
153
155
156
157 dst_num_indices = comm_size
158 DO i = 1, dst_num_indices
159 dst_index_list(i) = int(i - 1, xi)
160 END DO
161
163
164
166
167
169
170
171 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
172 mpi_comm_world)) &
173 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
174
175
176 IF (comm_rank == 0) THEN
177 DO i = 1, comm_size
178 src_data(i) = dble(i - 1)
179 END DO
180 ELSE
181 src_data(:) = -2.0d0
182 END IF
183
184 DO i = 1, comm_size
185 ref_dst_data(i) = dble(i-1)
186 END DO
187 CALL check_redist(redist, src_data, dst_data, ref_dst_data)
188
189
194 END SUBROUTINE nonuniform_test
195
196
197 SUBROUTINE block_redist_test
198
199 INTEGER :: ngdom, gvol_size, i, nwin, ig0, ig, j, p, qa, qb
200
201 INTEGER, ALLOCATABLE :: gdoma(:), gdomb(:), gsurfdata(:), &
202 gdepth(:), ig2col_off(:), b_surfdata_ref(:), gvoldata(:), &
203 src_block_offsets(:), src_block_sizes(:), dst_block_offsets(:), &
204 dst_block_sizes(:), b_voldata_ref(:)
205 INTEGER, ALLOCATABLE :: a_surfdata(:), b_surfdata(:), &
206 a_voldata(:), b_voldata(:)
207 INTEGER(xi), ALLOCATABLE :: iveca(:), ivecb(:)
208 INTEGER :: ia, ib, blk_ofs_accum, gdepth_i
209 TYPE(Xt_idxlist) :: idxlist_a, idxlist_b
210 TYPE(xt_xmap) :: xmap
211 TYPE(Xt_redist) :: redist, block_redist, block_redist2
212
213 IF (2 * comm_size > huge(1_xt_int_kind)) &
214 CALL test_abort('too large number of tasks', filename, __line__)
215
216 ngdom = 2 * comm_size
217
218 ALLOCATE(gdoma(ngdom), gdomb(ngdom))
219
220 ALLOCATE(gsurfdata(ngdom), gdepth(ngdom))
221 ALLOCATE(ig2col_off(ngdom))
222 gvol_size = 0
223 DO i = 1, ngdom
224 gdoma(i) = i - 1
225 gdomb(i) = ngdom - i
226 gsurfdata(i) = 99 + i
227 gdepth(i) = i
228 ig2col_off(i) = gvol_size
229 gvol_size = gvol_size + gdepth(i)
230 END DO
231
232 nwin = ngdom / comm_size
233
234 ig0 = comm_rank * nwin
235 IF (nwin * comm_size /= ngdom) &
236 CALL test_abort("internal error", filename, __line__)
237
238
239 ALLOCATE(iveca(nwin), ivecb(nwin))
240 DO i = 1, nwin
241 ig = ig0 + i
242 iveca(i) = int(gdoma(ig), xi)
243 ivecb(i) = int(gdomb(ig), xi)
244 END DO
245
248
250
251
253
254
255 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
256 mpi_comm_world)) &
257 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
258
259 ALLOCATE(a_surfdata(nwin), b_surfdata(nwin), b_surfdata_ref(nwin))
260 DO i = 1, nwin
261 a_surfdata(i) = gsurfdata(iveca(i) + 1)
262 b_surfdata(i) = -1
263 b_surfdata_ref(i) = gsurfdata(ivecb(i) + 1)
264 END DO
265
266 CALL check_redist(redist, a_surfdata, b_surfdata, b_surfdata_ref)
268
269
270 ALLOCATE(gvoldata(gvol_size))
271 DO i = 1, ngdom
272 DO j = 1, gdepth(i)
273 p = ig2col_off(i) + j
274 gvoldata(p) = (i - 1) * 100 + j - 1
275 END DO
276 END DO
277
278
279 ALLOCATE(src_block_offsets(nwin), src_block_sizes(nwin), &
280 dst_block_offsets(nwin), dst_block_sizes(nwin))
281
282 ALLOCATE(a_voldata(gvol_size), b_voldata(gvol_size), &
283 b_voldata_ref(gvol_size))
284 a_voldata(:) = -1
285 b_voldata_ref(:) = -1
286
287 qa = 0
288 blk_ofs_accum = 0
289 DO i = 1, nwin
290 ia = int(iveca(i)) + 1
291 gdepth_i = gdepth(ia)
292 src_block_offsets(i) = blk_ofs_accum
293 blk_ofs_accum = blk_ofs_accum + gdepth_i
294 src_block_sizes(i) = gdepth_i
295 p = ig2col_off(ia)
296 DO j = 1, gdepth_i
297 a_voldata(qa + j) = gvoldata(p + j)
298 END DO
299 qa = qa + gdepth_i
300 END DO
301
302 qb = 0
303 blk_ofs_accum = 0
304 DO i = 1, nwin
305 ib = int(ivecb(i)) + 1
306 gdepth_i = gdepth(ib)
307 dst_block_offsets(i) = blk_ofs_accum
308 blk_ofs_accum = blk_ofs_accum + gdepth_i
309 dst_block_sizes(i) = gdepth_i
310 p = ig2col_off(ib)
311 DO j = 1, gdepth_i
312 b_voldata_ref(qb + j) = gvoldata(p + j)
313 END DO
314 qb = qb + gdepth_i
315 END DO
316
317
319 src_block_offsets, src_block_sizes, nwin, &
320 dst_block_offsets, dst_block_sizes, nwin, mpi_integer, config)
321
322 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(block_redist), &
323 mpi_comm_world)) &
324 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
325
326 CALL check_redist(block_redist, a_voldata, b_voldata, b_voldata_ref)
327
328
330 src_block_sizes, nwin, dst_block_sizes, nwin, mpi_integer, config)
331
332
333 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(block_redist2),&
334 mpi_comm_world)) &
335 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
336
337 CALL check_redist(block_redist2, a_voldata, b_voldata, b_voldata_ref)
338
339
345 END SUBROUTINE block_redist_test
346
347END PROGRAM test_redist_p2p_parallel
348
349
350
351
352
353
354
355
356
void xt_config_delete(Xt_config config)
void xt_initialize(MPI_Comm default_comm)
void xt_idxlist_delete(Xt_idxlist idxlist)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
void xt_redist_delete(Xt_redist redist)
Xt_redist xt_redist_p2p_blocks_custom_new(Xt_xmap xmap, const int *src_block_sizes, int src_block_num, const int *dst_block_sizes, int dst_block_num, MPI_Datatype datatype, Xt_config config)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
Xt_redist xt_redist_p2p_blocks_off_custom_new(Xt_xmap xmap, const int *src_block_offsets, const int *src_block_sizes, int src_block_num, const int *dst_block_offsets, const int *dst_block_sizes, int dst_block_num, MPI_Datatype datatype, Xt_config config)
void xt_xmap_delete(Xt_xmap xmap)
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)