Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_xmap_intersection_parallel_f.f90
1!>
2!! @file test_xmap_intersection_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#include "fc_feature_defs.inc"
46PROGRAM test_xmap_intersection_parallel
47 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort, posix_exit
48 USE mpi
49 USE iso_c_binding, ONLY: c_int
50 USE test_idxlist_utils, ONLY: test_err_count
51 USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, &
53 xt_idxempty_new, xi => xt_int_kind, &
63 xt_xmap_iterator_delete, xt_xmap_reorder, xt_reorder_type_kind, &
64 xt_reorder_none, xt_reorder_send_up, xt_reorder_recv_up, &
65 xt_sort_permutation, xt_xmap_update_positions, xt_xmap_spread
66#if defined __PGI && ( __PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 7))
67 ! PGI Fortran 12.7 and older has a bug that prevents proper passing of
68 ! generic interfaces through multiple modules, direct USE instead
69 USE xt_xmap_abstract, ONLY: xt_is_null
70#else
71 USE yaxt, ONLY: xt_is_null
72#endif
73 IMPLICIT NONE
74
75 TYPE test_message
76 INTEGER :: rank ! rank of communication partner
77 INTEGER, POINTER :: pos(:) ! positions to be sent/received
78 END TYPE test_message
79
80 INTEGER, PARAMETER :: xmi_type_base = 0, xmi_type_ext = 1
81 INTEGER :: xmi_type
82
83 INTEGER :: ierror
84 INTEGER :: my_rank, comm_size
85 CHARACTER(len=*), PARAMETER :: &
86 filename = 'test_xmap_intersection_parallel_f.f90'
87
88 CALL init_mpi
89 CALL xt_initialize(mpi_comm_world)
90 xmi_type = xmi_type_base
91 CALL parse_options
92
93 CALL mpi_comm_rank(mpi_comm_world, my_rank, ierror)
94 IF (ierror /= mpi_success) &
95 CALL test_abort("MPI error!", filename, __line__)
96
97 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
98 IF (ierror /= mpi_success) &
99 CALL test_abort("MPI error!", filename, __line__)
100
101 IF (comm_size /= 3) THEN
102 CALL xt_finalize
103 CALL finish_mpi
104 CALL posix_exit(77_c_int)
105 END IF
106
107 ! parse_options(&argc, &argv);
108 CALL simple_rr_test
109 CALL elimination_test
110 CALL one_to_one_comm_test
111 CALL full_comm_matrix_test
112 CALL dedup_test
113 CALL reorder_test
114 CALL update_positions_and_spread_test
115 CALL alltoall_pos_test
116
117 IF (test_err_count() /= 0) &
118 CALL test_abort("non-zero error count!", filename, __line__)
119 CALL xt_finalize
120 CALL finish_mpi
121
122CONTAINS
123 ! simple test (round robin)
124 SUBROUTINE simple_rr_test
125 ! setup
126 INTEGER(xi) :: src_index(1), dst_index(1)
127 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
128 INTEGER, PARAMETER :: num_src_intersections = 1, &
129 num_dst_intersections = 1, num_sends = 1, num_recvs = 1
130 INTEGER, SAVE, TARGET :: send_pos(num_sends) = (/ 0 /), &
131 recv_pos(num_recvs) = (/ 0 /)
132 TYPE(xt_com_list) :: src_com(num_src_intersections), &
133 dst_com(num_dst_intersections)
134 TYPE(xt_xmap) :: xmap
135 TYPE(test_message) :: send_messages(1), recv_messages(1)
136
137 src_index(1) = int(my_rank, xi)
138 dst_index(1) = int(mod(my_rank + 1, comm_size), xi)
139 src_idxlist = xt_idxvec_new(src_index)
140 dst_idxlist = xt_idxvec_new(dst_index)
141 src_com(1) = xt_com_list(src_idxlist, mod(my_rank+1, comm_size))
142 dst_com(1) = xt_com_list(dst_idxlist, mod(my_rank+comm_size-1, comm_size))
143
144 xmap = xmi_new(src_com(1:num_src_intersections), &
145 dst_com(1:num_dst_intersections), &
146 src_idxlist, dst_idxlist, mpi_comm_world)
147
148 ! test
149 send_messages(1)%rank = mod(my_rank+1, comm_size)
150 send_messages(1)%pos => send_pos
151 recv_messages(1)%rank = mod(my_rank+comm_size-1, comm_size)
152 recv_messages(1)%pos => recv_pos
153
154 CALL test_xmap(xmap, send_messages, recv_messages)
155
156 ! cleanup
157 CALL xt_xmap_delete(xmap)
158 CALL xt_idxlist_delete(dst_idxlist)
159 CALL xt_idxlist_delete(src_idxlist)
160 END SUBROUTINE simple_rr_test
161
162 ! rank 0 receives the same point from rank 1 and 2
163 SUBROUTINE elimination_test
164 INTEGER(xi), PARAMETER :: src_index(1) = (/ 0_xi /), &
165 dst_index(1) = (/ 0_xi /)
166 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
167 INTEGER :: num_src_intersections, num_dst_intersections, num_sends, &
168 num_recvs
169 INTEGER, TARGET :: send_pos(1), recv_pos(1)
170 TYPE(xt_com_list) :: src_com(1), dst_com(2)
171 TYPE(xt_xmap) :: xmap
172 TYPE(test_message) :: send_messages(1), recv_messages(1)
173 ! setup
174 IF (my_rank == 0) THEN
175 src_idxlist = xt_idxempty_new()
176 dst_idxlist = xt_idxvec_new(dst_index)
177 ELSE
178 src_idxlist = xt_idxvec_new(src_index)
179 dst_idxlist = xt_idxempty_new()
180 END IF
181 num_src_intersections = merge(1, 0, my_rank /= 0)
182 src_com = xt_com_list(src_idxlist, 0)
183 num_dst_intersections = merge(0, 2, my_rank /= 0)
184 dst_com(1) = xt_com_list(dst_idxlist, 1)
185 dst_com(2) = xt_com_list(dst_idxlist, 2)
186
187 xmap = xmi_new(src_com(1:num_src_intersections), &
188 dst_com(1:num_dst_intersections), &
189 src_idxlist, dst_idxlist, mpi_comm_world)
190
191 ! test
192 send_pos(1) = 0
193 num_sends = merge(1, 0, my_rank == 1)
194 send_messages(1)%rank = 0
195 send_messages(1)%pos => send_pos
196 recv_pos(1) = 0;
197 num_recvs = merge(1, 0, my_rank == 0)
198 recv_messages(1)%rank = 1
199 recv_messages(1)%pos => recv_pos
200
201 CALL test_xmap(xmap, send_messages(1:num_sends), recv_messages(1:num_recvs))
202
203 ! cleanup
204
205 CALL xt_xmap_delete(xmap)
206 CALL xt_idxlist_delete(dst_idxlist)
207 CALL xt_idxlist_delete(src_idxlist)
208 END SUBROUTINE elimination_test
209
210 ! all ranks can receive data from one of the others
211 SUBROUTINE one_to_one_comm_test
212 ! rank | 0 | 1 | 2 |
213 ! source indices | 1,2 | 2,0 | 0,1 |
214 ! destination indice | 0 | 1 | 2 |
215
216 INTEGER(xi) :: src_indices(2), dst_index(1)
217 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist, src_intersection_idxlist(2)
218 INTEGER, PARAMETER :: num_src_intersections(3) = (/ 2, 1, 0 /)
219 INTEGER :: num_sends, num_recvs, s_s, s_e, i
220 INTEGER, TARGET :: send_pos(2), recv_pos(1)
221 TYPE(xt_com_list) :: src_com(2), dst_com(1)
222 TYPE(xt_xmap) :: xmap
223 TYPE(test_message) :: send_messages(2), recv_messages(1)
224 ! setup
225 dst_index(1) = int(my_rank, xi)
226 DO i = 1, 2
227 src_indices(i) = int(mod(my_rank+i, comm_size), xi)
228 src_intersection_idxlist(i) = xt_idxvec_new(src_indices(i:i), 1)
229 END DO
230 src_idxlist = xt_idxvec_new(src_indices, 2)
231 dst_idxlist = xt_idxvec_new(dst_index, 1)
232 src_com(1) = xt_com_list(src_intersection_idxlist(1), 1)
233 src_com(2) = xt_com_list(src_intersection_idxlist(2), &
234 merge(2, 0, my_rank == 0))
235 dst_com = xt_com_list(dst_idxlist, merge(1, 0, my_rank == 0))
236 s_s = merge(my_rank + 1, 1, my_rank /= 2)
237 s_e = s_s + num_src_intersections(my_rank + 1) - 1
238 xmap = xmi_new(src_com(s_s:s_e), dst_com(:), src_idxlist, dst_idxlist, &
239 mpi_comm_world)
240
241 ! test
242 recv_pos(1) = 0
243 num_recvs = 1
244 SELECT CASE (my_rank)
245 CASE (0)
246 send_pos(1) = 0
247 send_pos(2) = 1
248 num_sends = 2
249 send_messages(1)%rank = 1
250 send_messages(1)%pos => send_pos(1:1)
251 send_messages(2)%rank = 2
252 send_messages(2)%pos => send_pos(2:2)
253 recv_messages(1)%rank = 1
254 CASE (1)
255 send_pos = 1
256 num_sends = 1
257 send_messages(1)%rank = 0
258 send_messages(1)%pos => send_pos(1:1)
259 recv_messages(1)%rank = 0
260 CASE default
261 num_sends = 0
262 recv_messages(1)%rank = 0
263 END SELECT
264 recv_messages(1)%pos => recv_pos(1:1)
265 CALL test_xmap(xmap, send_messages(1:num_sends), recv_messages(1:num_recvs))
266
267 ! cleanup
268 CALL xt_xmap_delete(xmap)
269 CALL xt_idxlist_delete(src_intersection_idxlist(2))
270 CALL xt_idxlist_delete(src_intersection_idxlist(1))
271 CALL xt_idxlist_delete(dst_idxlist)
272 CALL xt_idxlist_delete(src_idxlist)
273 END SUBROUTINE one_to_one_comm_test
274
275 ! all ranks receive data from each of the others
276 SUBROUTINE full_comm_matrix_test
277 !rank | 0 | 1 | 2
278 !source indices | 0,1,2,3,4 | 3,4,5,6,7 | 6,7,8,0,1
279 !destination indices|0,1,2,3,4,5,6,7,8|0,1,2,3,4,5,6,7,8|0,1,2,3,4,5,6,7,8
280
281
282 INTEGER(xi), PARAMETER :: src_indices(5,0:2) &
283 = reshape((/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, &
284 & 3_xi, 4_xi ,5_xi, 6_xi, 7_xi, &
285 & 6_xi, 7_xi, 8_xi, 0_xi, 1_xi /), (/ 5, 3 /)), &
286 dst_indices(9) &
287 = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, 7_xi, 8_xi /)
288 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
289 TYPE(xt_com_list) :: src_com(0:2), dst_com(0:2)
290 TYPE(xt_xmap) :: xmap
291 INTEGER, SAVE, TARGET :: send_pos(5, 0:2) &
292 = reshape((/ 0,1,2,3,4, 2,3,4,-1,-1, 2,-1,-1,-1,-1 /), (/ 5, 3 /)), &
293 num_send_pos(0:2) = (/ 5, 3, 1 /), &
294 recv_pos(5, 0:2) &
295 = reshape((/ 0,1,2,3,4, 5,6,7,-1,-1, 8,-1,-1,-1,-1 /), (/ 5, 3 /)), &
296 num_recv_pos(0:2) = (/ 5, 3, 1 /)
297 TYPE(test_message) :: send_messages(0:2), recv_messages(0:2)
298 INTEGER :: i
299
300 ! setup
301 src_idxlist = xt_idxvec_new(src_indices(:, my_rank))
302 dst_idxlist = xt_idxvec_new(dst_indices, 9)
303 DO i = 0, 2
304 src_com(i) = xt_com_list(src_idxlist, i)
305 dst_com(i) = xt_com_list(xt_idxvec_new(src_indices(:, i)), i)
306 END DO
307 xmap = xmi_new(src_com, dst_com, src_idxlist, dst_idxlist, &
308 mpi_comm_world)
309
310 ! test
311 DO i = 0, 2
312 send_messages(i)%rank = i
313 send_messages(i)%pos => send_pos(1:num_send_pos(my_rank), my_rank)
314 recv_messages(i)%rank = i
315 recv_messages(i)%pos => recv_pos(1:num_recv_pos(i), i)
316 END DO
317 CALL test_xmap(xmap, send_messages, recv_messages)
318
319 ! cleanup
320 CALL xt_xmap_delete(xmap)
321 DO i = 2, 0, -1
322 CALL xt_idxlist_delete(dst_com(i)%list)
323 END DO
324 CALL xt_idxlist_delete(dst_idxlist)
325 CALL xt_idxlist_delete(src_idxlist)
326 END SUBROUTINE full_comm_matrix_test
327
328 ! one rank receives data from the other two, that have duplicated indices
329 ! (this provokes a bug found by Joerg Behrens)
330 SUBROUTINE dedup_test
331 ! rank | 0 | 1 | 2 |
332 ! source indices | 0,2 | 1,2 | |
333 ! destination indices | | | 0,1,2 |
334
335 INTEGER(xt_int_kind), PARAMETER :: src_indices(2, 0:1) &
336 = reshape((/ 0_xi,2_xi, 1_xi,2_xi /), (/ 2, 2 /))
337 TYPE(xt_com_list) :: src_com(1), dst_com(2)
338 INTEGER :: num_src_intersections, num_dst_intersections
339 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
340 INTEGER(xt_int_kind), PARAMETER :: dst_indices(3) = (/ 0_xi, 1_xi, 2_xi /)
341 TYPE(xt_xmap) :: xmap
342 INTEGER :: i, num_recv_messages, num_send_messages
343 INTEGER, PARAMETER :: num_recv_pos(2) = (/ 2, 1 /), &
344 num_send_pos(2) = (/ 2, 1 /)
345 INTEGER, SAVE, TARGET :: &
346 recv_pos(2, 2) = reshape((/ 0, 2, 1, -1 /), (/ 2, 2 /)), &
347 send_pos(2, 2) = reshape((/ 0, 1, 0, -1 /), (/ 2, 2 /))
348 TYPE(test_message) :: recv_messages(2), send_messages(1)
349 ! setup
350 IF (my_rank == 2) THEN
351 num_src_intersections = 0
352 num_dst_intersections = 2
353 DO i = 0, 1
354 dst_com(i+1)%list = xt_idxvec_new(src_indices(:, i))
355 dst_com(i+1)%rank = i
356 END DO
357 src_idxlist = xt_idxempty_new()
358 dst_idxlist = xt_idxvec_new(dst_indices(:))
359 ELSE
360 num_src_intersections = 1
361 src_com(1)%list = xt_idxvec_new(src_indices(:, my_rank))
362 src_com(1)%rank = 2
363 num_dst_intersections = 0;
364 src_idxlist = xt_idxvec_new(src_indices(:, my_rank))
365 dst_idxlist = xt_idxempty_new()
366 END IF
367 xmap = xmi_new(src_com(1:num_src_intersections), &
368 dst_com(1:num_dst_intersections), &
369 src_idxlist, dst_idxlist, mpi_comm_world)
370
371 ! test
372 IF (my_rank == 2) THEN
373 num_recv_messages = 2
374 num_send_messages = 0
375 DO i = 1, 2
376 recv_messages(i)%rank = i - 1
377 recv_messages(i)%pos => recv_pos(1:num_recv_pos(i), i)
378 END DO
379 ELSE
380 num_recv_messages = 0
381 num_send_messages = 1
382 send_messages(1)%rank = 2
383 send_messages(1)%pos => send_pos(1:num_send_pos(my_rank + 1), my_rank + 1)
384 END IF
385 CALL test_xmap(xmap, send_messages(1:num_send_messages), &
386 recv_messages(1:num_recv_messages))
387
388 ! cleanup
389 CALL xt_xmap_delete(xmap)
390 CALL xt_idxlist_delete(dst_idxlist)
391 CALL xt_idxlist_delete(src_idxlist)
392 CALL xt_idxlist_delete(dst_com(1:num_dst_intersections)%list)
393 CALL xt_idxlist_delete(src_com(1:num_src_intersections)%list)
394 END SUBROUTINE dedup_test
395
396 ! checks the reorder functionality of exchange maps
397 SUBROUTINE reorder_test
398
399 INTEGER(xt_int_kind), PARAMETER :: src_indices(6) &
400 = (/ 0_xi, 5_xi, 1_xi, 4_xi, 2_xi, 3_xi /)
401 INTEGER(xt_int_kind), PARAMETER :: dst_indices(6) &
402 = (/ 5_xi, 4_xi, 3_xi, 2_xi, 1_xi, 0_xi /)
403 INTEGER(xt_int_kind), PARAMETER :: intersection_indices(6) &
404 = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, 5_xi /)
405 TYPE(xt_com_list) :: src_com(1), dst_com(1)
406 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
407 TYPE(xt_xmap) :: xmap, xmap_reorder
408 INTEGER(xt_reorder_type_kind), PARAMETER :: reorder_types(3) &
409 = (/ xt_reorder_none, xt_reorder_send_up, xt_reorder_recv_up/)
410 INTEGER :: i
411 INTEGER, SAVE, TARGET :: send_pos(6), recv_pos(6)
412 TYPE(test_message) :: recv_messages(1), send_messages(1)
413
414 ! setup
415 src_idxlist = xt_idxvec_new(src_indices(:))
416 dst_idxlist = xt_idxvec_new(dst_indices(:))
417 src_com(1)%list = xt_idxvec_new(intersection_indices)
418 src_com(1)%rank = mod(my_rank + 1, comm_size)
419 dst_com(1)%list = xt_idxvec_new(intersection_indices)
420 dst_com(1)%rank = mod(comm_size + my_rank - 1, comm_size)
421 xmap = xmi_new(src_com, dst_com, src_idxlist, dst_idxlist, mpi_comm_world)
422
423 send_messages(1)%rank = mod(my_rank + 1, comm_size)
424 send_messages(1)%pos => send_pos
425 recv_messages(1)%rank = mod(comm_size + my_rank - 1, comm_size)
426 recv_messages(1)%pos => recv_pos
427
428 ! test
429 DO i = 1, 3
430 xmap_reorder = xt_xmap_reorder(xmap, reorder_types(i))
431 send_pos = (/ 0, 2, 4, 5, 3, 1 /)
432 recv_pos = (/ 5, 4, 3, 2, 1, 0 /)
433 SELECT CASE(reorder_types(i))
434 CASE(xt_reorder_send_up)
435 CALL xt_sort_permutation(send_pos, recv_pos)
436 CASE(xt_reorder_recv_up)
437 CALL xt_sort_permutation(recv_pos, send_pos)
438 END SELECT
439 CALL test_xmap(xmap_reorder, send_messages, recv_messages)
440 CALL xt_xmap_delete(xmap_reorder)
441 END DO
442
443 ! cleanup
444 CALL xt_xmap_delete(xmap)
445 CALL xt_idxlist_delete(dst_idxlist)
446 CALL xt_idxlist_delete(src_idxlist)
447 CALL xt_idxlist_delete(dst_com(1)%list)
448 CALL xt_idxlist_delete(src_com(1)%list)
449 END SUBROUTINE reorder_test
450
451 ! checks the update positions functionality of exchange maps
452 SUBROUTINE update_positions_and_spread_test
453
454 INTEGER(xt_int_kind), PARAMETER :: indices(12) &
455 = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, 7_xi, 8_xi, 9_xi, 10_xi, 11_xi /)
456 TYPE(xt_com_list) :: src_com(1), dst_com(1)
457 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
458 TYPE(xt_xmap) :: xmap, xmap_single_level_blocked, xmap_multi_level_blocked
459 INTEGER :: i, idx, blk, lev
460 INTEGER, PARAMETER :: nproma = 4, nblk = 3, nlev = 6
461 INTEGER, SAVE, TARGET :: blocked_positions(72)
462 INTEGER :: displacements(6)
463 TYPE(test_message) :: recv_messages(1), send_messages(1)
464
465 ! setup
466 src_idxlist = xt_idxvec_new(indices)
467 dst_idxlist = xt_idxvec_new(indices)
468 src_com(1)%list = xt_idxvec_new(indices)
469 src_com(1)%rank = mod(my_rank + 1, comm_size)
470 dst_com(1)%list = xt_idxvec_new(indices)
471 dst_com(1)%rank = mod(comm_size + my_rank - 1, comm_size)
472 xmap = xmi_new(src_com, dst_com, src_idxlist, dst_idxlist, mpi_comm_world)
473
474 i = 1
475 DO lev = 0, nlev - 1
476 DO blk = 0, nblk - 1
477 DO idx = 0, nproma - 1
478 blocked_positions(i) = idx + (blk * nlev + lev) * nproma
479 i = i + 1
480 END DO
481 END DO
482 END DO
483 DO i = 1, nlev
484 displacements(i) = (i - 1) * nproma
485 END DO
486
487 xmap_single_level_blocked = &
488 xt_xmap_update_positions(xmap, blocked_positions, blocked_positions);
489 xmap_multi_level_blocked = &
491 xmap_single_level_blocked, nlev, displacements, displacements);
492
493 send_messages(1)%rank = mod(my_rank + 1, comm_size)
494 send_messages(1)%pos => blocked_positions
495 recv_messages(1)%rank = mod(comm_size + my_rank - 1, comm_size)
496 recv_messages(1)%pos => blocked_positions
497
498 ! test
499 CALL test_xmap(xmap_multi_level_blocked, send_messages, recv_messages)
500
501 ! cleanup
502 CALL xt_xmap_delete(xmap_multi_level_blocked)
503 CALL xt_xmap_delete(xmap_single_level_blocked)
504 CALL xt_xmap_delete(xmap)
505 CALL xt_idxlist_delete(dst_idxlist)
506 CALL xt_idxlist_delete(src_idxlist)
507 CALL xt_idxlist_delete(dst_com(1)%list)
508 CALL xt_idxlist_delete(src_com(1)%list)
509 END SUBROUTINE update_positions_and_spread_test
510
511 ! checks xt_xmap_intersection_pos_new constructor
512 SUBROUTINE alltoall_pos_test
513
514 TYPE(xt_xmap) :: xmap
515 TYPE(xt_com_pos), TARGET :: src_com(comm_size), dst_com(comm_size)
516 INTEGER, TARGET :: transfer_pos(comm_size)
517 TYPE(test_message) :: recv_messages(comm_size), send_messages(comm_size)
518 INTEGER :: i
519
520 DO i = 1, comm_size
521 transfer_pos(i) = i
522 src_com(i)%transfer_pos => transfer_pos(i:i)
523 src_com(i)%rank = i - 1
524 dst_com(i)%transfer_pos => transfer_pos(i:i)
525 dst_com(i)%rank = i - 1
526 send_messages(i)%rank = i - 1
527 send_messages(i)%pos => transfer_pos(i:i)
528 recv_messages(i)%rank = i - 1
529 recv_messages(i)%pos => transfer_pos(i:i)
530 END DO
531
532 xmap = xt_xmap_intersection_pos_new(src_com, dst_com, mpi_comm_world)
533
534 ! test
535 CALL test_xmap(xmap, send_messages, recv_messages)
536
537 ! cleanup
538 CALL xt_xmap_delete(xmap)
539 END SUBROUTINE alltoall_pos_test
540
541 SUBROUTINE test_xmap_iter(iter, msgs)
542 TYPE(xt_xmap_iter), INTENT(inout) :: iter
543 TYPE(test_message), INTENT(in) :: msgs(:)
544
545 INTEGER :: num_msgs, num_pos, num_pos_ext, i, j, ofs, pe, pos_ext_size
546 INTEGER, POINTER :: pos(:)
547 TYPE(xt_pos_ext), POINTER :: pos_ext(:)
548 LOGICAL :: iter_is_null, mismatch
549
550 num_msgs = SIZE(msgs)
551 iter_is_null = xt_is_null(iter)
552 IF (num_msgs == 0) THEN
553 IF (.NOT. iter_is_null) &
554 CALL test_abort('ERROR: xt_xmap_get_*_iterator (non-null when &
555 &iter should be null)', &
556 filename, __line__)
557 ELSE IF (iter_is_null) THEN
558 CALL test_abort('ERROR: xt_xmap_get_*_iterator &
559 &(iter should not be NULL)', &
560 filename, __line__)
561 ELSE
562 i = 1
563 DO WHILE(.true.)
564 IF (xt_xmap_iterator_get_rank(iter) /= msgs(i)%rank) &
565 CALL test_abort('ERROR: xt_xmap_iterator_get_rank', &
566 filename, __line__)
567 num_pos = SIZE(msgs(i)%pos)
568 IF (xt_xmap_iterator_get_num_transfer_pos(iter) /= num_pos) THEN
569 CALL test_abort("ERROR: xt_xmap_iterator_get_num_transfer_pos", &
570 filename, __line__)
571 END IF
573 mismatch = .false.
574 DO j = 1, num_pos
575 mismatch = mismatch .OR. pos(j) /= msgs(i)%pos(j)
576 END DO
577 IF (mismatch) &
578 CALL test_abort('ERROR: xt_xmap_iterator_get_transfer_pos', &
579 filename, __line__)
580
583 ofs = 0
584 mismatch = .false.
585 DO pe = 1, num_pos_ext
586 pos_ext_size = abs(pos_ext(pe)%size)
587 IF (pos_ext(pe)%size > 0) THEN
588 DO j = 1, pos_ext_size
589 mismatch = mismatch .OR. pos(ofs+j) /= pos_ext(pe)%start + j - 1
590 END DO
591 ELSE
592 DO j = 1, pos_ext_size
593 mismatch = mismatch .OR. pos(ofs+j) /= pos_ext(pe)%start - j + 1
594 END DO
595 END IF
596 ofs = ofs + pos_ext_size
597 END DO
598 IF (mismatch .OR. ofs /= num_pos) &
599 CALL test_abort('ERROR: xt_xmap_iterator_get_transfer_pos_ext', &
600 filename, __line__)
601
602 IF (.NOT. xt_xmap_iterator_next(iter)) EXIT
603 i = i + 1
604 END DO
605 IF (i /= num_msgs) &
606 CALL test_abort('ERROR: xt_xmap_iterator_next &
607 &(wrong number of messages)', &
608 filename, __line__)
609 END IF
610 END SUBROUTINE test_xmap_iter
611
612 SUBROUTINE test_xmap(xmap, send_messages, recv_messages)
613 TYPE(xt_xmap), INTENT(in) :: xmap
614 TYPE(test_message), INTENT(in) :: send_messages(:), recv_messages(:)
615
616 INTEGER :: num_sends, num_recvs
617 TYPE(xt_xmap_iter) :: send_iter, recv_iter
618 INTEGER, PARAMETER :: num_xmaps_2_test = 2
619 INTEGER :: i
620 TYPE(xt_xmap) :: maps(num_xmaps_2_test)
621
622 maps(1) = xmap
623 maps(2) = xt_xmap_copy(xmap)
624 DO i = 1, num_xmaps_2_test
625 num_sends = SIZE(send_messages)
626 num_recvs = SIZE(recv_messages)
627 IF (xt_xmap_get_num_destinations(maps(i)) /= num_sends) &
628 CALL test_abort('ERROR: xt_xmap_get_num_destinations', filename, &
629 __line__)
630 IF (xt_xmap_get_num_sources(maps(i)) /= num_recvs) &
631 CALL test_abort('ERROR: xt_xmap_get_num_sources', filename, __line__)
632 send_iter = xt_xmap_get_out_iterator(maps(i))
633 recv_iter = xt_xmap_get_in_iterator(maps(i))
634
635 CALL test_xmap_iter(send_iter, send_messages)
636 CALL test_xmap_iter(recv_iter, recv_messages)
637
638 IF (.NOT. xt_is_null(recv_iter)) CALL xt_xmap_iterator_delete(recv_iter)
639 IF (.NOT. xt_is_null(send_iter)) CALL xt_xmap_iterator_delete(send_iter)
640 END DO
641 CALL xt_xmap_delete(maps(2))
642 END SUBROUTINE test_xmap
643
644 SUBROUTINE parse_options
645 INTEGER :: i, num_cmd_args, arg_len
646 INTEGER, PARAMETER :: max_opt_arg_len = 80
647 CHARACTER(max_opt_arg_len) :: optarg
648 num_cmd_args = command_argument_count()
649 i = 1
650 DO WHILE (i < num_cmd_args)
651 CALL get_command_argument(i, optarg, arg_len)
652 IF (optarg(1:2) == '-m' .AND. i < num_cmd_args .AND. arg_len == 2) THEN
653 CALL get_command_argument(i + 1, optarg, arg_len)
654 IF (arg_len > max_opt_arg_len) &
655 CALL test_abort('incorrect argument to command-line option -m', &
656 filename, __line__)
657 IF (optarg(1:arg_len) == "xt_xmap_intersection_new") THEN
658 xmi_type = xmi_type_base
659 ELSE IF (optarg(1:arg_len) == "xt_xmap_intersection_ext_new") THEN
660 xmi_type = xmi_type_ext
661 ELSE
662 WRITE (0, *) 'arg to -m: ', optarg(1:arg_len)
663 CALL test_abort('incorrect argument to command-line option -m', &
664 filename, __line__)
665 END IF
666 i = i + 2
667 ELSE
668 WRITE (0, *) 'unexpected command-line argument parsing error: ', &
669 trim(optarg)
670 FLUSH(0)
671 CALL test_abort('unexpected command-line argument -m', filename, &
672 __line__)
673 END IF
674 END DO
675 END SUBROUTINE parse_options
676
677 FUNCTION xmi_new(src_com, dst_com, src_idxlist, dst_idxlist, comm) &
678 result(xmap)
679 TYPE(xt_com_list), INTENT(in) :: src_com(:), dst_com(:)
680 TYPE(xt_idxlist), INTENT(in) :: src_idxlist, dst_idxlist
681 INTEGER, INTENT(in) :: comm
682 TYPE(xt_xmap) :: xmap
683 SELECT CASE(xmi_type)
684 CASE(xmi_type_base)
685 xmap = xt_xmap_intersection_new(src_com, dst_com, &
686 src_idxlist, dst_idxlist, comm)
687 CASE(xmi_type_ext)
688 xmap = xt_xmap_intersection_ext_new(src_com, dst_com, &
689 src_idxlist, dst_idxlist, comm)
690 END SELECT
691 END FUNCTION xmi_new
692
693END PROGRAM test_xmap_intersection_parallel
694!
695! Local Variables:
696! f90-continuation-indent: 5
697! coding: utf-8
698! indent-tabs-mode: nil
699! show-trailing-whitespace: t
700! require-trailing-newline: t
701! End:
702!
describes range of positions starting with start up to start + size - 1 i.e. [start,...
Definition xt_core_f.f90:94
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_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
int xt_xmap_iterator_next(Xt_xmap_iter iter)
Definition xt_xmap.c:101
Xt_xmap xt_xmap_reorder(Xt_xmap xmap, enum xt_reorder_type type)
Definition xt_xmap.c:143
void xt_xmap_delete(Xt_xmap xmap)
Definition xt_xmap.c:86
Xt_xmap_iter xt_xmap_get_out_iterator(Xt_xmap xmap)
Definition xt_xmap.c:96
int xt_xmap_iterator_get_num_transfer_pos_ext(Xt_xmap_iter iter)
Definition xt_xmap.c:126
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
void xt_xmap_iterator_delete(Xt_xmap_iter iter)
Definition xt_xmap.c:130
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_iterator_get_rank(Xt_xmap_iter iter)
Definition xt_xmap.c:106
int xt_xmap_get_num_sources(Xt_xmap xmap)
Definition xt_xmap.c:66
const struct Xt_pos_ext * xt_xmap_iterator_get_transfer_pos_ext(Xt_xmap_iter iter)
Definition xt_xmap.c:122
Xt_xmap_iter xt_xmap_get_in_iterator(Xt_xmap xmap)
Definition xt_xmap.c:91
int const * xt_xmap_iterator_get_transfer_pos(Xt_xmap_iter iter)
Definition xt_xmap.c:111
int xt_xmap_iterator_get_num_transfer_pos(Xt_xmap_iter iter)
Definition xt_xmap.c:116
Xt_xmap xt_xmap_intersection_ext_new(int num_src_intersections, const struct Xt_com_list src_com[num_src_intersections], int num_dst_intersections, const struct Xt_com_list dst_com[num_dst_intersections], Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)
Xt_xmap xt_xmap_intersection_pos_new(int num_src_msg, const struct Xt_com_pos src_com[num_src_msg], int num_dst_msg, const struct Xt_com_pos dst_com[num_dst_msg], MPI_Comm comm)
Xt_xmap xt_xmap_intersection_new(int num_src_intersections, const struct Xt_com_list src_com[num_src_intersections], int num_dst_intersections, const struct Xt_com_list dst_com[num_dst_intersections], Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)