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#include "fc_feature_defs.inc"
49PROGRAM test_redist_collection_parallel
50 USE mpi
51 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort, icbrt
52 USE test_idxlist_utils, ONLY: test_err_count
61
62#if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
64#endif
65 USE test_redist_common, ONLY: check_wait_request, redist_exchanger_option
66 USE iso_c_binding, ONLY: c_loc, c_ptr
67#include "xt_slice_c_loc.inc"
68 IMPLICIT NONE
69 INTEGER :: rank, world_size, ierror
70 CHARACTER(len=*), PARAMETER :: &
71 filename = 'test_redist_collection_parallel_f.f90'
72 CHARACTER(len=*), PARAMETER :: err_msg(2) = &
73 (/ "error in xt_redist_s_exchange", "error in xt_redist_a_exchange" /)
74 TYPE(xt_config) :: config
75
76 CALL init_mpi
78 config = redist_exchanger_option()
79
80 CALL mpi_comm_rank(mpi_comm_world, rank, ierror)
81 IF (ierror /= mpi_success) &
82 CALL test_abort('mpi_comm_rank failed', filename, __line__)
83 CALL mpi_comm_size(mpi_comm_world, world_size, ierror)
84 IF (ierror /= mpi_success) &
85 CALL test_abort('mpi_comm_size failed', filename, __line__)
86
87 IF (world_size > 1) THEN
88 CALL test_4redist(mpi_comm_world, config)
89 CALL test_rr_exchange(mpi_comm_world, config)
90 END IF
91
92 IF (test_err_count() /= 0) &
93 CALL test_abort("non-zero error count!", filename, __line__)
96 CALL finish_mpi
97CONTAINS
98 SUBROUTINE build_idxlists(indices_a, indices_b, indices_all)
99 TYPE(xt_idxlist), INTENT(out) :: indices_a, indices_b, indices_all
100
101 TYPE(xt_idxlist) :: indices_a_(2)
102 INTEGER :: i
103 INTEGER(xt_int_kind), PARAMETER :: start = 0
104 INTEGER(xt_int_kind) :: global_size(2), local_start(2, 2)
105 INTEGER :: local_size(2)
106
107 TYPE(xt_stripe) :: stripe
108
109 global_size(1) = int(2 * world_size, xi)
110 global_size(2) = int(world_size**2, xi)
111 local_size = world_size
112 local_start = reshape((/ 0_xi, int(rank*world_size, xi), &
113 int(world_size, xi), &
114 int((world_size-(rank+1))*world_size, xi) /), (/ 2, 2 /))
115
116 DO i = 1, 2
118 local_start(:, i))
119 END DO
121
124
125 stripe =
xt_stripe(int(rank * 2 * world_size**2, xi), 1_xi, 2*world_size**2)
127
128 stripe =
xt_stripe(0_xi, 1_xi, 2*world_size**3)
130 END SUBROUTINE build_idxlists
131
132 SUBROUTINE test_4redist(comm, config)
133
134 INTEGER, INTENT(in) :: comm
135 TYPE(xt_config), INTENT(in) :: config
136 INTEGER, PARAMETER :: num_tx = 4
137 TYPE(xt_idxlist) :: indices_a, indices_b, indices_all
138 INTEGER(xt_int_kind), ALLOCATABLE :: index_vector_a(:), &
139 index_vector_b(:)
140 TYPE(xt_xmap) :: xmaps(num_tx)
141 TYPE(xt_redist) :: redists(num_tx), redist, redist_copy
142 INTEGER :: i, vec_size
143
144 IF (world_size &
145 > icbrt((huge(1_xi)-mod(huge(1_xi),2_xi))/2_xi)) &
146 CALL test_abort('communicator too large for test', filename, __line__)
147
148 vec_size = 2*world_size**2
149 ALLOCATE(index_vector_a(vec_size), index_vector_b(vec_size))
150 CALL build_idxlists(indices_a, indices_b, indices_all)
151
156
159
163
164 DO i = 1, num_tx
167 END DO
168
170
171
172
173
174
176
177 CALL exchange_4redist(redist, index_vector_a, index_vector_b)
180 CALL exchange_4redist(redist_copy, index_vector_a, index_vector_b)
181
182
184 END SUBROUTINE test_4redist
185
186 SUBROUTINE exchange_4redist(redist, index_vector_a, index_vector_b)
187 TYPE(xt_redist), INTENT(in) :: redist
188 INTEGER(xt_int_kind), INTENT(in) :: index_vector_a(2*world_size**2), &
189 index_vector_b(2*world_size**2)
190 INTEGER(xt_int_kind), TARGET, ALLOCATABLE :: buf(:)
191 INTEGER(xt_int_kind), POINTER :: results_1(:), &
192 results_2(:), results_3(:), results_4(:)
193 INTEGER :: result_sizes(4), buf_size, ofs
194 INTEGER, PARAMETER :: result_spacing(4) = (/ 2, 14, 5, 8 /)
195 INTEGER :: iexch
196
197 result_sizes(1) = 2*world_size**2
198 result_sizes(2) = 2*world_size**2
199 result_sizes(3) = 2*world_size**3
200 result_sizes(4) = 2*world_size**3
201
202 buf_size = sum(result_spacing) + sum(result_sizes)
203 ALLOCATE(buf(buf_size))
204 DO iexch = 1, 2
205 buf(:) = -1_xt_int_kind
206 ofs = result_spacing(1)
207 results_1 => buf(ofs+1:ofs+result_sizes(1))
208 ofs = ofs + result_sizes(1) + result_spacing(2)
209 results_2 => buf(ofs+1:ofs+result_sizes(2))
210 ofs = ofs + result_sizes(2) + result_spacing(3)
211 results_3 => buf(ofs+1:ofs+result_sizes(3))
212 ofs = ofs + result_sizes(3) + result_spacing(4)
213 results_4 => buf(ofs+1:ofs+result_sizes(4))
214
215 CALL do_4redist(redist, index_vector_a, index_vector_b, &
216 results_1, results_2, results_3, results_4, iexch)
217
218 CALL check_4redist_results(results_1, results_2, results_3, results_4, &
219 index_vector_a, index_vector_b, iexch)
220 buf(:) = -1_xt_int_kind
221
222 IF (rank == 0) THEN
223 ofs = sum(result_spacing(1:2)) + sum(result_sizes(1:2))
224 results_3 => buf(ofs+1:ofs+result_sizes(3))
225 END IF
226
227 CALL do_4redist(redist, index_vector_a, index_vector_b, &
228 results_1, results_2, results_3, results_4, iexch)
229
230 CALL check_4redist_results(results_1, results_2, results_3, results_4, &
231 index_vector_a, index_vector_b, iexch)
232 ENDDO
233
234 DEALLOCATE(buf)
235 END SUBROUTINE exchange_4redist
236
237 SUBROUTINE do_4redist(redist, index_vector_a, index_vector_b, &
238 results_1, results_2, results_3, results_4, iexch)
239 TYPE(xt_redist), INTENT(in) :: redist
240 INTEGER(xt_int_kind), INTENT(in), TARGET :: &
241 index_vector_a(*), index_vector_b(*)
242 INTEGER(xt_int_kind), INTENT(inout), TARGET :: &
243 results_1(*), results_2(*), results_3(*), results_4(*)
244 INTEGER, INTENT(in) :: iexch
245
246 TYPE(c_ptr) :: results(4), input(4)
247 TYPE(xt_request) :: request
248
249 results(1) = c_loc(results_1)
250 results(2) = c_loc(results_2)
251 results(3) = c_loc(results_3)
252 results(4) = c_loc(results_4)
253
254 input(1) = c_loc(index_vector_a)
255 input(2) = c_loc(index_vector_b)
256 input(3) = c_loc(index_vector_a)
257 input(4) = c_loc(index_vector_b)
258 IF (iexch == 1) THEN
260 ELSE
262 CALL check_wait_request(request, filename, __line__)
263 ENDIF
264 END SUBROUTINE do_4redist
265
266 SUBROUTINE check_4redist_results(results_1, results_2, results_3, results_4, &
267 index_vector_a, index_vector_b, iexch)
268 INTEGER(xt_int_kind), INTENT(in) :: index_vector_a(:), index_vector_b(:), &
269 results_1(:), results_2(:), results_3(0:), results_4(0:)
270 INTEGER, INTENT(in) :: iexch
271 INTEGER(xt_int_kind) :: i, n
272 LOGICAL :: p_3, p_4
273
274 IF (any(results_1 /= index_vector_b)) &
275 CALL test_abort(err_msg(iexch), filename, __line__)
276
277 IF (any(results_2 /= index_vector_a)) &
278 CALL test_abort(err_msg(iexch), filename, __line__)
279
280 n = int(SIZE(results_3), xt_int_kind)
281 p_3 = .false.
282 p_4 = .false.
283 DO i = 0_xi, n - 1_xi
284 p_3 = p_3 .OR. results_3(i) /= i
285 p_4 = p_4 .OR. results_4(i) /= i
286 END DO
287 IF (p_3 .OR. p_4) CALL test_abort(err_msg(iexch), filename, __line__)
288 END SUBROUTINE check_4redist_results
289
290
291
292
293 SUBROUTINE test_rr_exchange(comm, config)
294 INTEGER, INTENT(in) :: comm
295 TYPE(xt_config), INTENT(in) :: config
296
297 TYPE(xt_idxlist) :: src_indices, dst_indices(2)
298 INTEGER(xt_int_kind) :: src_indices_(5)
299 INTEGER(xt_int_kind) :: i, temp, dst_indices_(5, 2)
300 TYPE(xt_xmap) :: xmaps(2)
301 TYPE(xt_redist) :: redists(2), redist, redist_copy
302
303 IF (world_size > (huge(1_xi)-mod(huge(1_xi),5_xi))/5_xi) &
304 CALL test_abort('communicator too large for test', filename, __line__)
305
306 DO i = 1_xi, 5_xi
307 src_indices_(i) = int(rank, xi) * 5_xi + (i - 1_xi)
308 dst_indices_(i, 1) = mod(src_indices_(i) + 1_xi, &
309 & int(world_size, xi) * 5_xi)
310 temp = src_indices_(i) - 1_xi
311 dst_indices_(i, 2) = merge(int(world_size, xi) * 5_xi - 1_xi, &
312 & temp, temp < 0_xi)
313 END DO
314
318
321
324
327
329
331
332
333
334
335
337
338 CALL rr_exchange(redist, src_indices_, dst_indices_)
341 CALL rr_exchange(redist_copy, src_indices_, dst_indices_)
342
343
345 END SUBROUTINE test_rr_exchange
346
347 SUBROUTINE rr_exchange(redist, src_indices_, ref_dst_indices_)
348#if defined __GNUC__ && __GNUC__ >= 5 && ( __GNUC__ <= 7 \
349 || __gnuc__ == 8 && __gnuc_minor__ < 4 )
350
351
352
353
354 USE yaxt, ONLY: xt_slice_c_loc
355#undef XT_SLICE_C_LOC
356#define XT_SLICE_C_LOC(slice, cptr) CALL xt_slice_c_loc(slice, cptr)
357#endif
358 TYPE(xt_redist), INTENT(in) :: redist
359 INTEGER, PARAMETER :: nredist = 2
360 INTEGER(xt_int_kind), TARGET, INTENT(in) :: src_indices_(5)
361 INTEGER(xt_int_kind), INTENT(in) :: ref_dst_indices_(5, nredist)
362
363 INTEGER(xt_int_kind), TARGET :: results(5,nredist)
364 TYPE(c_ptr) :: results_p(nredist), input(nredist)
365 INTEGER :: iexch, i
366 TYPE(xt_request) :: request
367
368 DO i = 1, nredist
369 xt_slice_c_loc(results(:,i), results_p(i))
370 input(i) = c_loc(src_indices_)
371 END DO
372
373 DO iexch = 1, 2
374 results = -1
375
376 IF (iexch == 1) THEN
378 ELSE
380 CALL check_wait_request(request, filename, __line__)
381 ENDIF
382
383
384 IF (any(results /= ref_dst_indices_)) &
385 CALL test_abort(err_msg(iexch), filename, __line__)
386 ENDDO
387 END SUBROUTINE rr_exchange
388
389END PROGRAM test_redist_collection_parallel
390
391
392
393
394
395
396
397
398
void xt_config_delete(Xt_config config)
void xt_initialize(MPI_Comm default_comm)
void xt_idxlist_get_indices(Xt_idxlist idxlist, Xt_int *indices)
void xt_idxlist_delete(Xt_idxlist idxlist)
Xt_idxlist xt_idxlist_collection_new(Xt_idxlist *idxlists, int num_idxlists)
Xt_idxlist xt_idxsection_new(Xt_int start, int num_dimensions, const Xt_int global_size[num_dimensions], const int local_size[num_dimensions], const Xt_int local_start[num_dimensions])
Xt_idxlist xt_idxstripes_new(struct Xt_stripe const *stripes, int num_stripes)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
void xt_redist_delete(Xt_redist redist)
Xt_redist xt_redist_copy(Xt_redist redist)
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[])
void xt_redist_a_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[], Xt_request *request)
Xt_redist xt_redist_collection_new(Xt_redist *redists, int num_redists, int cache_size, MPI_Comm comm)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
void xt_xmap_delete(Xt_xmap xmap)
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)