Yet Another eXchange Tool 0.11.4
Loading...
Searching...
No Matches
test_redist_collection_parallel_f.f90
1
13
14!
15! Keywords:
16! Maintainer: Jörg Behrens <behrens@dkrz.de>
17! Moritz Hanke <hanke@dkrz.de>
18! Thomas Jahns <jahns@dkrz.de>
19! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
20!
21! Redistribution and use in source and binary forms, with or without
22! modification, are permitted provided that the following conditions are
23! met:
24!
25! Redistributions of source code must retain the above copyright notice,
26! this list of conditions and the following disclaimer.
27!
28! Redistributions in binary form must reproduce the above copyright
29! notice, this list of conditions and the following disclaimer in the
30! documentation and/or other materials provided with the distribution.
31!
32! Neither the name of the DKRZ GmbH nor the names of its contributors
33! may be used to endorse or promote products derived from this software
34! without specific prior written permission.
35!
36! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
37! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
38! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
39! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
40! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
41! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
42! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
43! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
44! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
45! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
46! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
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
53 USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, xi => xt_int_kind, &
59 xt_idxlist_get_indices, xt_int_mpidt, &
61 ! older PGI compilers do not handle generic interface correctly
62#if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
63 USE xt_redist_base, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
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
77 CALL xt_initialize(mpi_comm_world)
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__)
94 CALL xt_config_delete(config)
95 CALL xt_finalize
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
117 indices_a_(i) = xt_idxsection_new(start, global_size, local_size, &
118 local_start(:, i))
119 END DO
120 indices_a = xt_idxlist_collection_new(indices_a_)
121
122 CALL xt_idxlist_delete(indices_a_(1))
123 CALL xt_idxlist_delete(indices_a_(2))
124
125 stripe = xt_stripe(int(rank * 2 * world_size**2, xi), 1_xi, 2*world_size**2)
126 indices_b = xt_idxstripes_new(stripe)
127
128 stripe = xt_stripe(0_xi, 1_xi, 2*world_size**3)
129 indices_all = xt_idxstripes_new(stripe)
130 END SUBROUTINE build_idxlists
131
132 SUBROUTINE test_4redist(comm, config)
133 ! redist test with four different redists
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
152 xmaps(1) = xt_xmap_all2all_new(indices_a, indices_b, comm)
153 xmaps(2) = xt_xmap_all2all_new(indices_b, indices_a, comm)
154 xmaps(3) = xt_xmap_all2all_new(indices_a, indices_all, comm)
155 xmaps(4) = xt_xmap_all2all_new(indices_b, indices_all, comm)
156
157 CALL xt_idxlist_get_indices(indices_a, index_vector_a)
158 CALL xt_idxlist_get_indices(indices_b, index_vector_b)
159
160 CALL xt_idxlist_delete(indices_a)
161 CALL xt_idxlist_delete(indices_b)
162 CALL xt_idxlist_delete(indices_all)
163
164 DO i = 1, num_tx
165 redists(i) = xt_redist_p2p_new(xmaps(i), xt_int_mpidt)
166 CALL xt_xmap_delete(xmaps(i))
167 END DO
168
169 redist = xt_redist_collection_new(redists, num_tx, -1, comm, config)
170
171 ! test communicator of redist
172 ! if (!test_communicator(xt_redist_get_MPI_Comm(redist), COMM))
173 ! PUT_ERR("error in xt_redist_get_MPI_Comm\n");
174
175 CALL xt_redist_delete(redists)
176
177 CALL exchange_4redist(redist, index_vector_a, index_vector_b)
178 redist_copy = xt_redist_copy(redist)
179 CALL xt_redist_delete(redist)
180 CALL exchange_4redist(redist_copy, index_vector_a, index_vector_b)
181
182 ! clean up
183 CALL xt_redist_delete(redist_copy)
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 ! shift addresses around
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 ! clean up
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
259 CALL xt_redist_s_exchange(redist, 4, input, results)
260 ELSE
261 CALL xt_redist_a_exchange(redist, 4, input, results, request)
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 ! redist test with two redists that do a round robin exchange in
292 ! different directions
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
315 src_indices = xt_idxvec_new(src_indices_, 5)
316 dst_indices(1) = xt_idxvec_new(dst_indices_(:, 1))
317 dst_indices(2) = xt_idxvec_new(dst_indices_(:, 2))
318
319 xmaps(1) = xt_xmap_all2all_new(src_indices, dst_indices(1), comm)
320 xmaps(2) = xt_xmap_all2all_new(src_indices, dst_indices(2), comm)
321
322 CALL xt_idxlist_delete(src_indices)
323 CALL xt_idxlist_delete(dst_indices)
324
325 redists(1) = xt_redist_p2p_new(xmaps(1), xt_int_mpidt)
326 redists(2) = xt_redist_p2p_new(xmaps(2), xt_int_mpidt)
327
328 CALL xt_xmap_delete(xmaps)
329
330 redist = xt_redist_collection_new(redists, 2, -1, comm, config)
331
332 ! test communicator of redist
333 ! IF (!test_communicator(xt_redist_get_MPI_Comm(redist), comm))
334 ! PUT_ERR("error in xt_redist_get_MPI_Comm\n");
335
336 CALL xt_redist_delete(redists)
337
338 CALL rr_exchange(redist, src_indices_, dst_indices_)
339 redist_copy = xt_redist_copy(redist)
340 CALL xt_redist_delete(redist)
341 CALL rr_exchange(redist_copy, src_indices_, dst_indices_)
342
343 ! clean up
344 CALL xt_redist_delete(redist_copy)
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 ! gcc versions 5.x to 8.x have a bug that lets them evaluate the
351 ! ANY test too early if results never gets passed to some external
352 ! routine directly, 9.x is not only fixed again, but requires to
353 ! have the explicit escaping of a pointer to results via C_LOC
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
377 CALL xt_redist_s_exchange(redist, input, results_p)
378 ELSE
379 CALL xt_redist_a_exchange(redist, input, results_p, request)
380 CALL check_wait_request(request, filename, __line__)
381 ENDIF
382
383 ! check results
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! Local Variables:
392! f90-continuation-indent: 5
393! coding: utf-8
394! indent-tabs-mode: nil
395! show-trailing-whitespace: t
396! require-trailing-newline: t
397! End:
398!
void xt_config_delete(Xt_config config)
Definition xt_config.c:85
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92
void xt_idxlist_get_indices(Xt_idxlist idxlist, Xt_int *indices)
Definition xt_idxlist.c:113
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
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)
Definition xt_idxvec.c:213
void xt_redist_delete(Xt_redist redist)
Definition xt_redist.c:74
Xt_redist xt_redist_copy(Xt_redist redist)
Definition xt_redist.c:69
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[])
Definition xt_redist.c:79
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)
Definition xt_xmap.c:86
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)