Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_xmap_common_parallel_f.f90
1!>
2!! @file test_xmap_common_parallel_f.f90
3!!
4!! @copyright Copyright (C) 2016 Jörg Behrens <behrens@dkrz.de>
5!! Moritz Hanke <hanke@dkrz.de>
6!! Thomas Jahns <jahns@dkrz.de>
7!!
8!! @author Jörg Behrens <behrens@dkrz.de>
9!! Moritz Hanke <hanke@dkrz.de>
10!! Thomas Jahns <jahns@dkrz.de>
11!!
12!
13! Keywords:
14! Maintainer: Jörg Behrens <behrens@dkrz.de>
15! Moritz Hanke <hanke@dkrz.de>
16! Thomas Jahns <jahns@dkrz.de>
17! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
18!
19! Redistribution and use in source and binary forms, with or without
20! modification, are permitted provided that the following conditions are
21! met:
22!
23! Redistributions of source code must retain the above copyright notice,
24! this list of conditions and the following disclaimer.
25!
26! Redistributions in binary form must reproduce the above copyright
27! notice, this list of conditions and the following disclaimer in the
28! documentation and/or other materials provided with the distribution.
29!
30! Neither the name of the DKRZ GmbH nor the names of its contributors
31! may be used to endorse or promote products derived from this software
32! without specific prior written permission.
33!
34! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
35! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
36! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
37! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
38! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
39! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
40! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
41! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
42! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
43! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
44! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
45!
46#include "fc_feature_defs.inc"
47MODULE test_xmap_common_parallel
48 USE mpi
49 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
50 USE test_idxlist_utils, ONLY: test_err_count
51 USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, xt_stripe, &
52 xi => xt_int_kind, xt_sort_int, &
60 IMPLICIT NONE
61 PRIVATE
62 PUBLIC :: xmap_parallel_test_main
63 PUBLIC :: get_rank_range
64 PUBLIC :: check_allgather_analog_xmap
65 PUBLIC :: test_ring_1d
66 PUBLIC :: test_ping_pong
67 CHARACTER(len=*), PARAMETER :: filename = 'test_xmap_common_parallel_f.f90'
68CONTAINS
69 SUBROUTINE xmap_parallel_test_main(xmap_new)
70 INTERFACE
71 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
72 IMPORT :: xt_idxlist, xt_xmap
73 IMPLICIT NONE
74 TYPE(xt_idxlist), INTENT(in) :: src_idxlist
75 TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
76 INTEGER, INTENT(in) :: comm
77 TYPE(xt_xmap) :: res
78 END FUNCTION xmap_new
79 END INTERFACE
80 INTEGER :: comm, comm_rank, comm_size
81 INTEGER :: ierror
82 CALL init_mpi
83 comm = mpi_comm_world
84 CALL xt_initialize(comm)
85 CALL mpi_comm_rank(comm, comm_rank, ierror)
86 IF (ierror /= mpi_success) &
87 CALL test_abort("error calling mpi_comm_rank", filename, __line__)
88 CALL mpi_comm_size(comm, comm_size, ierror)
89 IF (ierror /= mpi_success) &
90 CALL test_abort("error calling mpi_comm_size", filename, __line__)
91 IF (comm_size > huge(1_xi)) &
92 CALL test_abort("number of ranks exceeds test limit", &
93 filename, __line__)
94
95 CALL test_allgather_analog(xmap_new, 1, comm)
96 ! repeat test for large index list that will cause stripifying
97 CALL test_allgather_analog(xmap_new, 1024, comm)
98 IF (comm_size > 2) CALL test_ring_1d(xmap_new, comm)
99 IF (comm_size == 2) CALL test_pair(xmap_new, comm)
100 IF (comm_size > 1) CALL test_ping_pong(xmap_new, comm, 0, comm_size - 1)
101
102 ! test maxpos implementation for xt_xmap_intersection
103 CALL test_maxpos(xmap_new, comm, 5)
104 ! test maxpos implementation for xt_xmap_intersection_ext
105 CALL test_maxpos(xmap_new, comm, 501)
106
107 IF (test_err_count() /= 0) &
108 CALL test_abort("non-zero error count!", filename, __line__)
109 CALL xt_finalize
110 CALL finish_mpi
111 END SUBROUTINE xmap_parallel_test_main
112
113 SUBROUTINE get_rank_range(comm, is_inter, comm_rank, comm_size)
114 INTEGER, INTENT(inout) :: comm
115 INTEGER, INTENT(out) :: comm_rank, comm_size
116 LOGICAL, INTENT(out) :: is_inter
117 INTEGER :: ierror
118
119 CALL mpi_comm_rank(comm, comm_rank, ierror)
120 IF (ierror /= mpi_success) &
121 CALL test_abort("error calling mpi_comm_rank", filename, __line__)
122 CALL mpi_comm_test_inter(comm, is_inter, ierror)
123 IF (ierror /= mpi_success) &
124 CALL test_abort("error calling mpi_comm_test_inter", &
125 filename, __line__)
126 IF (is_inter) THEN
127 CALL mpi_comm_remote_size(comm, comm_size, ierror)
128 ELSE
129 CALL mpi_comm_size(comm, comm_size, ierror)
130 END IF
131 IF (ierror /= mpi_success) &
132 CALL test_abort("error calling mpi_comm_(remote)_size", &
133 filename, __line__)
134 END SUBROUTINE get_rank_range
135
136 SUBROUTINE check_allgather_analog_xmap(xmap, comm)
137 TYPE(xt_xmap), INTENT(in) :: xmap
138 INTEGER, INTENT(inout) :: comm
139 INTEGER, ALLOCATABLE :: ranks(:)
140 INTEGER(xt_int_kind) :: i
141 INTEGER :: comm_rank, comm_size
142 LOGICAL :: is_inter
143
144 CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
145 IF (xt_xmap_get_num_destinations(xmap) /= int(comm_size, xi)) &
146 CALL test_abort("error in xmap construction", filename, __line__)
147
148 IF (xt_xmap_get_num_sources(xmap) /= int(comm_size, xi)) &
149 CALL test_abort("error in xt_xmap_get_num_sources", &
150 filename, __line__)
151
152 ALLOCATE(ranks(comm_size))
153
154 CALL xt_xmap_get_destination_ranks(xmap, ranks)
155 IF (any(ranks /= (/ (i, i=0_xi,int(comm_size-1, xi)) /))) &
156 CALL test_abort("error in xt_xmap_get_destination_ranks", &
157 filename, __line__)
158
159 CALL xt_xmap_get_source_ranks(xmap, ranks)
160 IF (any(ranks /= (/ (i, i=0_xi,int(comm_size-1, xi)) /))) &
161 CALL test_abort("error in xt_xmap_get_source_ranks", &
162 filename, __line__)
163 DEALLOCATE(ranks)
164 END SUBROUTINE check_allgather_analog_xmap
165
166 SUBROUTINE test_allgather_analog(xmap_new, num_indices_per_rank, comm)
167 INTERFACE
168 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
169 IMPORT :: xt_idxlist, xt_xmap
170 IMPLICIT NONE
171 TYPE(xt_idxlist), INTENT(in) :: src_idxlist
172 TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
173 INTEGER, INTENT(in) :: comm
174 TYPE(xt_xmap) :: res
175 END FUNCTION xmap_new
176 END INTERFACE
177 INTEGER, INTENT(inout) :: comm
178 INTEGER, INTENT(in) :: num_indices_per_rank
179 INTEGER(xi), ALLOCATABLE :: src_index_list(:)
180 INTEGER(xi) :: i
181 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
182 TYPE(xt_xmap) :: xmap, xmap_copy
183 TYPE(xt_stripe) :: dst_index_stripe(1)
184 INTEGER :: comm_size, comm_rank
185 INTEGER(xi) :: comm_rank_xi, num_indices_per_rank_xi
186 LOGICAL :: is_inter
187
188 CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
189 comm_rank_xi = int(comm_rank, xi)
190 num_indices_per_rank_xi = int(num_indices_per_rank, xi)
191 ! setup
192 ALLOCATE(src_index_list(num_indices_per_rank))
193 DO i = 1_xi, num_indices_per_rank
194 src_index_list(i) = comm_rank_xi * num_indices_per_rank_xi + i - 1_xi
195 END DO
196 src_idxlist = xt_idxvec_new(src_index_list)
197 dst_index_stripe(1) = xt_stripe(0, 1, comm_size * num_indices_per_rank)
198 dst_idxlist = xt_idxstripes_new(dst_index_stripe)
199 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
200 CALL xt_idxlist_delete(src_idxlist)
201 CALL xt_idxlist_delete(dst_idxlist)
202
203 ! verify expected results
204 CALL check_allgather_analog_xmap(xmap, comm)
205 xmap_copy = xt_xmap_copy(xmap)
206 CALL check_allgather_analog_xmap(xmap, comm)
207
208 ! clean up
209 CALL xt_xmap_delete(xmap)
210 CALL xt_xmap_delete(xmap_copy)
211 END SUBROUTINE test_allgather_analog
212
213 SUBROUTINE check_ring_xmap(xmap, dst_index_list, is_inter)
214 TYPE(xt_xmap), INTENT(in) :: xmap
215 INTEGER(xt_int_kind), INTENT(in) :: dst_index_list(2)
216 LOGICAL, INTENT(in) :: is_inter
217 INTEGER :: ranks(2), num_dst, num_src
218 num_dst = xt_xmap_get_num_destinations(xmap)
219 IF (.NOT. is_inter .AND. (num_dst > 2 .OR. num_dst < 1)) &
220 CALL test_abort("error in xt_xmap_get_num_destinations", &
221 filename, __line__)
222
223 num_src = xt_xmap_get_num_sources(xmap)
224 IF (num_src > 2 .OR. num_src < 1) &
225 CALL test_abort("error in xt_xmap_get_num_sources", filename, __line__)
226
227 IF (.NOT. is_inter) THEN
228 CALL xt_xmap_get_destination_ranks(xmap, ranks)
229 CALL xt_sort_int(ranks(1:num_dst))
230 IF (any(ranks /= dst_index_list)) &
231 CALL test_abort("error in xt_xmap_get_destination_ranks", &
232 filename, __line__)
233 END IF
234
235 CALL xt_xmap_get_source_ranks(xmap, ranks)
236 CALL xt_sort_int(ranks(1:num_src))
237 IF (any(ranks /= dst_index_list)) &
238 CALL test_abort("error in xt_xmap_get_source_ranks", &
239 filename, __line__)
240 END SUBROUTINE check_ring_xmap
241
242 SUBROUTINE test_ring_1d(xmap_new, comm)
243 INTERFACE
244 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
245 IMPORT :: xt_idxlist, xt_xmap
246 IMPLICIT NONE
247 TYPE(xt_idxlist), INTENT(in) :: src_idxlist
248 TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
249 INTEGER, INTENT(in) :: comm
250 TYPE(xt_xmap) :: res
251 END FUNCTION xmap_new
252 END INTERFACE
253 INTEGER, INTENT(inout) :: comm
254 ! test in which each process talks WITH two other processes
255 INTEGER(xt_int_kind) :: src_index_list(1), dst_index_list(2), temp
256 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
257 TYPE(xt_xmap) :: xmap, xmap_copy
258 INTEGER :: comm_size, comm_rank
259 LOGICAL :: is_inter
260
261 CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
262 src_index_list(1) = int(comm_rank, xi)
263 src_idxlist = xt_idxvec_new(src_index_list)
264
265 ! destination index list
266 dst_index_list(1) = int(mod(comm_rank + comm_size - 1, comm_size), xi)
267 dst_index_list(2) = int(mod(comm_rank + 1, comm_size), xi)
268 IF (dst_index_list(1) > dst_index_list(2)) THEN
269 temp = dst_index_list(1)
270 dst_index_list(1) = dst_index_list(2)
271 dst_index_list(2) = temp
272 END IF
273 dst_idxlist = xt_idxvec_new(dst_index_list, 2)
274
275 ! test of exchange map
276 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
277 CALL xt_idxlist_delete(src_idxlist)
278 CALL xt_idxlist_delete(dst_idxlist)
279
280 ! test results
281 CALL check_ring_xmap(xmap, dst_index_list, is_inter)
282 xmap_copy = xt_xmap_copy(xmap)
283 CALL check_ring_xmap(xmap_copy, dst_index_list, is_inter)
284
285 ! clean up
286 CALL xt_xmap_delete(xmap)
287 CALL xt_xmap_delete(xmap_copy)
288
289 END SUBROUTINE test_ring_1d
290
291 SUBROUTINE test_maxpos(xmap_new, comm, indices_per_rank)
292 INTERFACE
293 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
294 IMPORT :: xt_idxlist, xt_xmap
295 IMPLICIT NONE
296 TYPE(xt_idxlist), INTENT(in) :: src_idxlist
297 TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
298 INTEGER, INTENT(in) :: comm
299 TYPE(xt_xmap) :: res
300 END FUNCTION xmap_new
301 END INTERFACE
302 INTEGER, INTENT(in) :: comm
303 INTEGER, INTENT(in) :: indices_per_rank
304 ! first setup simple pattern of boundary exchange
305 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
306 TYPE(xt_xmap) :: xmap, xmup, xmup2, xmsp
307 INTEGER :: indices_for_exch
308 INTEGER(xt_int_kind) :: src_index(indices_per_rank), &
309 dst_index(indices_per_rank)
310 INTEGER :: max_pos_src, max_pos_dst, max_pos_src_u, max_pos_dst_u, &
311 max_pos_src_u2, max_pos_dst_u2, max_pos_src_s, max_pos_dst_s
312 INTEGER :: comm_rank, comm_size, world_size
313 INTEGER :: ierror
314 INTEGER :: i, xmspread(2)
315 INTEGER :: pos_update1(indices_per_rank), pos_update2(2*indices_per_rank)
316
317 CALL mpi_comm_rank(comm, comm_rank, ierror)
318 IF (ierror /= mpi_success) &
319 CALL test_abort("error calling mpi_comm_rank", filename, __line__)
320 CALL mpi_comm_size(comm, comm_size, ierror)
321 IF (ierror /= mpi_success) &
322 CALL test_abort("error calling mpi_comm_size", filename, __line__)
323
324 world_size = comm_size * indices_per_rank
325
326 ! setup
327 indices_for_exch = indices_per_rank/2
328 DO i = 1, indices_per_rank
329 src_index(i) = int(i-1 + comm_rank * indices_per_rank, xi)
330 END DO
331 DO i = 1, indices_for_exch
332 dst_index(i) = int(mod(i - 1 - indices_for_exch &
333 + (comm_rank+comm_size) * indices_per_rank, world_size), xi)
334 END DO
335 DO i = indices_for_exch+1, indices_per_rank-indices_for_exch
336 dst_index(i) = int(i-1 + comm_rank * indices_per_rank, xi)
337 END DO
338 DO i = 1, indices_for_exch
339 dst_index(indices_per_rank-indices_for_exch+i) &
340 = int(mod(i + (comm_rank+1) * indices_per_rank, world_size), xi)
341 END DO
342 src_idxlist = xt_idxvec_new(src_index)
343 dst_idxlist = xt_idxvec_new(dst_index)
344
345 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
346 CALL xt_idxlist_delete(src_idxlist)
347 CALL xt_idxlist_delete(dst_idxlist)
348
349 ! test
350 ! 1. test that initial max positions are in range
351 max_pos_dst = xt_xmap_get_max_dst_pos(xmap)
352 max_pos_src = xt_xmap_get_max_src_pos(xmap)
353 IF (max_pos_src < indices_per_rank-1) &
354 CALL test_abort("error in xt_xmap_get_max_src_pos", filename, __line__)
355 IF (max_pos_dst < indices_per_rank-1) &
356 CALL test_abort("error in xt_xmap_get_max_dst_pos", filename, __line__)
357
358 ! 2. expand range and verify it is reflected in max pos
359 DO i = 1,indices_per_rank
360 pos_update1(i) = (i-1)*2
361 END DO
362
363 xmup = xt_xmap_update_positions(xmap, pos_update1, pos_update1)
364
365 max_pos_dst_u = xt_xmap_get_max_dst_pos(xmup)
366 max_pos_src_u = xt_xmap_get_max_src_pos(xmup)
367 IF (max_pos_src_u < (indices_per_rank-1)*2) &
368 CALL test_abort("error in xt_xmap_get_max_src_pos", filename, __line__)
369 IF (max_pos_dst_u < (indices_per_rank-1)*2) &
370 CALL test_abort("error in xt_xmap_get_max_dst_pos", filename, __line__)
371
372 ! 3. contract range again and verify max pos is updated
373 DO i = 1, indices_per_rank*2
374 pos_update2(i) = (i-1)/2
375 END DO
376 xmup2 = xt_xmap_update_positions(xmap, pos_update2, pos_update2)
377
378 max_pos_dst_u2 = xt_xmap_get_max_dst_pos(xmup2)
379 max_pos_src_u2 = xt_xmap_get_max_src_pos(xmup2)
380 IF (max_pos_src_u2 >= indices_per_rank) &
381 CALL test_abort("error in xt_xmap_get_max_src_pos", filename, __line__)
382 IF (max_pos_dst_u2 >= indices_per_rank) &
383 CALL test_abort("error in xt_xmap_get_max_dst_pos", filename, __line__)
384
385 ! 4. apply spread and check max pos range
386 xmspread(1) = 0
387 xmspread(2) = indices_per_rank*3
388 xmsp = xt_xmap_spread(xmap, 2, xmspread, xmspread)
389 max_pos_dst_s = xt_xmap_get_max_dst_pos(xmsp)
390 max_pos_src_s = xt_xmap_get_max_src_pos(xmsp)
391 IF (max_pos_dst_s < (indices_per_rank-1)*3) &
392 CALL test_abort("error in xt_xmap_get_max_dst_pos", filename, __line__)
393 IF (max_pos_src_s < (indices_per_rank-1)*3) &
394 CALL test_abort("error in xt_xmap_get_max_src_pos", filename, __line__)
395
396 ! cleanup
397 CALL xt_xmap_delete(xmap)
398 CALL xt_xmap_delete(xmup)
399 CALL xt_xmap_delete(xmup2)
400 CALL xt_xmap_delete(xmsp)
401 END SUBROUTINE test_maxpos
402
403 SUBROUTINE check_pair_xmap(xmap)
404 TYPE(xt_xmap), INTENT(in) :: xmap
405 INTEGER :: ranks(2)
406 ! test results
407 IF (xt_xmap_get_num_destinations(xmap) /= 2) &
408 CALL test_abort("error in xt_xmap_get_num_destinations", &
409 filename, __line__)
410
411 IF (xt_xmap_get_num_sources(xmap) /= 2) &
412 CALL test_abort("error in xt_xmap_get_num_sources", filename, __line__)
413
414 CALL xt_xmap_get_destination_ranks(xmap, ranks)
415 IF (ranks(1) /= 0 .OR. ranks(2) /= 1) &
416 CALL test_abort("error in xt_xmap_get_destination_ranks", &
417 filename, __line__)
418
419 CALL xt_xmap_get_source_ranks(xmap, ranks)
420 IF (ranks(1) /= 0 .OR. ranks(2) /= 1) &
421 CALL test_abort("error in xt_xmap_get_source_ranks", &
422 filename, __line__)
423 END SUBROUTINE check_pair_xmap
424
425 SUBROUTINE test_pair(xmap_new, comm)
426 INTERFACE
427 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
428 IMPORT :: xt_idxlist, xt_xmap
429 IMPLICIT NONE
430 TYPE(xt_idxlist), INTENT(in) :: src_idxlist
431 TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
432 INTEGER, INTENT(in) :: comm
433 TYPE(xt_xmap) :: res
434 END FUNCTION xmap_new
435 END INTERFACE
436 INTEGER, INTENT(in) :: comm
437 !src_index_list(index, rank)
438 INTEGER(xt_int_kind) :: i, j, k
439#ifdef __xlC__
440 INTEGER(xt_int_kind), PARAMETER :: src_index_list(20, 0:1) = reshape((/ &
441 & 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, &
442 & 9_xi, 10_xi, 11_xi, 12_xi, 13_xi, &
443 & 17_xi, 18_xi, 19_xi, 20_xi, 21_xi, &
444 & 25_xi, 26_xi, 27_xi, 28_xi, 29_xi, &
445 & 4_xi, 5_xi, 6_xi, 7_xi, 8_xi, &
446 & 12_xi, 13_xi, 14_xi, 15_xi, 16_xi, &
447 & 20_xi, 21_xi, 22_xi, 23_xi, 24_xi, &
448 & 28_xi, 29_xi, 30_xi, 31_xi, 32_xi /), &
449 (/ 20, 2 /))
450#else
451 INTEGER(xt_int_kind), PARAMETER :: src_index_list(20, 0:1) = reshape((/ &
452 (((i + j * 8_xi + k * 3_xi, i = 1_xi, 5_xi), j = 0_xi,3_xi), &
453 k = 0_xi,1_xi) /), (/ 20, 2 /))
454#endif
455 ! dst_index_list(index,rank)
456 INTEGER(xt_int_kind), PARAMETER :: dst_index_list(20, 0:1) = reshape((/ &
457 10_xi, 15_xi, 14_xi, 13_xi, 12_xi, &
458 15_xi, 10_xi, 11_xi, 12_xi, 13_xi, &
459 23_xi, 18_xi, 19_xi, 20_xi, 21_xi, &
460 31_xi, 26_xi, 27_xi, 28_xi, 29_xi, &
461 13_xi, 12_xi, 11_xi, 10_xi, 15_xi, &
462 12_xi, 13_xi, 14_xi, 15_xi, 10_xi, &
463 20_xi, 21_xi, 22_xi, 23_xi, 18_xi, &
464 28_xi, 29_xi, 30_xi, 31_xi, 26_xi /), &
465 (/ 20, 2 /))
466 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
467 TYPE(xt_xmap) :: xmap, xmap_copy
468 INTEGER :: comm_rank, ierror
469
470 CALL mpi_comm_rank(comm, comm_rank, ierror)
471 IF (ierror /= mpi_success) &
472 CALL test_abort("error calling mpi_comm_rank", filename, __line__)
473
474 src_idxlist = xt_idxvec_new(src_index_list(:, comm_rank))
475
476 ! destination index list
477 dst_idxlist = xt_idxvec_new(dst_index_list(:, comm_rank))
478
479 ! test of exchange map
480 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
481 CALL xt_idxlist_delete(src_idxlist)
482 CALL xt_idxlist_delete(dst_idxlist)
483
484 CALL check_pair_xmap(xmap)
485 xmap_copy = xt_xmap_copy(xmap)
486 CALL check_pair_xmap(xmap_copy)
487
488 ! clean up
489 CALL xt_xmap_delete(xmap)
490 CALL xt_xmap_delete(xmap_copy)
491 END SUBROUTINE test_pair
492
493 SUBROUTINE check_ping_pong_xmap(xmap, comm, ping_rank, pong_rank)
494 TYPE(xt_xmap), INTENT(in) :: xmap
495 INTEGER, INTENT(in) :: comm, ping_rank, pong_rank
496 INTEGER :: expect, dst_rank(1), src_rank(1), comm_rank, ierror
497 CHARACTER(len=80) :: msg
498
499 CALL mpi_comm_rank(comm, comm_rank, ierror)
500 IF (ierror /= mpi_success) &
501 CALL test_abort('error calling mpi_comm_rank', filename, __line__)
502 WRITE (msg, '(a,i0,a)') "error in xt_xmap_get_num_destinations (rank == ", &
503 comm_rank, ")"
504 expect = merge(1, 0, comm_rank == ping_rank)
505 IF (xt_xmap_get_num_destinations(xmap) /= expect) &
506 CALL test_abort(msg, filename, __line__)
507
508 expect = merge(1, 0, comm_rank == pong_rank)
509 IF (xt_xmap_get_num_sources(xmap) /= expect) &
510 CALL test_abort(msg, filename, __line__)
511
512 IF (comm_rank == ping_rank) THEN
513 CALL xt_xmap_get_destination_ranks(xmap, dst_rank)
514 IF (dst_rank(1) /= pong_rank) &
515 CALL test_abort("error in xt_xmap_get_destination_ranks", &
516 filename, __line__)
517 END IF
518 IF (comm_rank == pong_rank) THEN
519 CALL xt_xmap_get_source_ranks(xmap, src_rank)
520 IF (src_rank(1) /= ping_rank) &
521 CALL test_abort("error in xt_xmap_get_source_ranks", &
522 filename, __line__)
523 END IF
524 END SUBROUTINE check_ping_pong_xmap
525
526 SUBROUTINE test_ping_pong(xmap_new, comm, ping_rank, pong_rank)
527 INTERFACE
528 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
529 IMPORT :: xt_idxlist, xt_xmap
530 IMPLICIT NONE
531 TYPE(xt_idxlist), INTENT(in) :: src_idxlist
532 TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
533 INTEGER, INTENT(in) :: comm
534 TYPE(xt_xmap) :: res
535 END FUNCTION xmap_new
536 END INTERFACE
537 INTEGER, INTENT(in) :: ping_rank, pong_rank
538 INTEGER, INTENT(inout) :: comm
539 INTEGER(xt_int_kind), PARAMETER :: &
540 index_list(5) = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi /)
541 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
542 TYPE(xt_xmap) :: xmap, xmap_copy
543 INTEGER :: comm_rank, comm_size
544 LOGICAL :: is_inter
545 CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
546 IF (comm_rank == ping_rank) THEN
547 src_idxlist = xt_idxvec_new(index_list)
548 ELSE
549 src_idxlist = xt_idxempty_new()
550 END IF
551
552
553 IF (comm_rank == pong_rank) THEN
554 dst_idxlist = xt_idxvec_new(index_list)
555 ELSE
556 dst_idxlist = xt_idxempty_new()
557 END IF
558
559 ! test of exchange map
560
561 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
562 CALL xt_idxlist_delete(src_idxlist)
563 CALL xt_idxlist_delete(dst_idxlist)
564
565 ! test results
566 CALL check_ping_pong_xmap(xmap, comm, ping_rank, pong_rank)
567 xmap_copy = xt_xmap_copy(xmap)
568 CALL check_ping_pong_xmap(xmap_copy, comm, ping_rank, pong_rank)
569 ! clean up
570 CALL xt_xmap_delete(xmap)
571 CALL xt_xmap_delete(xmap_copy)
572 END SUBROUTINE test_ping_pong
573END MODULE test_xmap_common_parallel
574!
575! Local Variables:
576! f90-continuation-indent: 5
577! coding: utf-8
578! indent-tabs-mode: nil
579! show-trailing-whitespace: t
580! require-trailing-newline: t
581! End:
582!
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92
Xt_idxlist xt_idxempty_new(void)
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
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
Xt_xmap xt_xmap_update_positions(Xt_xmap xmap, const int *src_positions, const int *dst_positions)
Definition xt_xmap.c:154
void xt_xmap_delete(Xt_xmap xmap)
Definition xt_xmap.c:86
Xt_xmap xt_xmap_spread(Xt_xmap xmap, int num_repetitions, const int src_displacements[num_repetitions], const int dst_displacements[num_repetitions])
Definition xt_xmap.c:159
int xt_xmap_get_num_destinations(Xt_xmap xmap)
Definition xt_xmap.c:61
Xt_xmap xt_xmap_copy(Xt_xmap xmap)
Definition xt_xmap.c:81
int xt_xmap_get_max_dst_pos(Xt_xmap xmap)
Definition xt_xmap.c:139
int xt_xmap_get_num_sources(Xt_xmap xmap)
Definition xt_xmap.c:66
void xt_xmap_get_source_ranks(Xt_xmap xmap, int *ranks)
Definition xt_xmap.c:76
void xt_xmap_get_destination_ranks(Xt_xmap xmap, int *ranks)
Definition xt_xmap.c:71
int xt_xmap_get_max_src_pos(Xt_xmap xmap)
Definition xt_xmap.c:135