46 MODULE test_xmap_common_parallel
48 USE ftest_common,
ONLY: init_mpi, finish_mpi, test_abort
49 USE test_idxlist_utils,
ONLY: test_err_count
51 xi => xt_int_kind, xt_sort_int, &
61 PUBLIC :: xmap_parallel_test_main
62 PUBLIC :: get_rank_range
63 PUBLIC :: check_allgather_analog_xmap
64 PUBLIC :: test_ring_1d
65 PUBLIC :: test_ping_pong
66 CHARACTER(len=*),
PARAMETER :: filename =
'test_xmap_common_parallel_f.f90'
68 SUBROUTINE xmap_parallel_test_main(xmap_new)
70 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm)
RESULT(res)
71 IMPORT :: xt_idxlist, xt_xmap
73 TYPE(xt_idxlist),
INTENT(in) :: src_idxlist
74 TYPE(xt_idxlist),
INTENT(in) :: dst_idxlist
75 INTEGER,
VALUE,
INTENT(in) :: comm
79 INTEGER :: comm, comm_rank, comm_size
84 CALL mpi_comm_rank(comm, comm_rank, ierror)
85 IF (ierror /= mpi_success) &
86 CALL test_abort(
"error calling mpi_comm_rank", filename, __line__)
87 CALL mpi_comm_size(comm, comm_size, ierror)
88 IF (ierror /= mpi_success) &
89 CALL test_abort(
"error calling mpi_comm_size", filename, __line__)
90 IF (comm_size > huge(1_xi)) &
91 CALL test_abort(
"number of ranks exceeds test limit", &
94 CALL test_allgather_analog(xmap_new, 1, comm)
96 CALL test_allgather_analog(xmap_new, 1024, comm)
97 IF (comm_size > 2)
CALL test_ring_1d(xmap_new, comm)
98 IF (comm_size == 2)
CALL test_pair(xmap_new, comm)
99 IF (comm_size > 1)
CALL test_ping_pong(xmap_new, comm, 0, comm_size - 1)
102 CALL test_maxpos(xmap_new, comm, 5)
104 CALL test_maxpos(xmap_new, comm, 501)
106 IF (test_err_count() /= 0) &
107 CALL test_abort(
"non-zero error count!", filename, __line__)
110 END SUBROUTINE xmap_parallel_test_main
112 SUBROUTINE get_rank_range(comm, is_inter, comm_rank, comm_size)
113 INTEGER,
INTENT(inout) :: comm
114 INTEGER,
INTENT(out) :: comm_rank, comm_size
115 LOGICAL,
INTENT(out) :: is_inter
118 CALL mpi_comm_rank(comm, comm_rank, ierror)
119 IF (ierror /= mpi_success) &
120 CALL test_abort(
"error calling mpi_comm_rank", filename, __line__)
121 CALL mpi_comm_test_inter(comm, is_inter, ierror)
122 IF (ierror /= mpi_success) &
123 CALL test_abort(
"error calling mpi_comm_test_inter", &
126 CALL mpi_comm_remote_size(comm, comm_size, ierror)
128 CALL mpi_comm_size(comm, comm_size, ierror)
130 IF (ierror /= mpi_success) &
131 CALL test_abort(
"error calling mpi_comm_(remote)_size", &
133 END SUBROUTINE get_rank_range
135 SUBROUTINE check_allgather_analog_xmap(xmap, comm)
136 TYPE(xt_xmap),
INTENT(in) :: xmap
137 INTEGER,
INTENT(inout) :: comm
138 INTEGER,
ALLOCATABLE :: ranks(:)
139 INTEGER(xt_int_kind) :: i
140 INTEGER :: comm_rank, comm_size
143 CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
145 CALL test_abort(
"error in xmap construction", filename, __line__)
148 CALL test_abort(
"error in xt_xmap_get_num_sources", &
151 ALLOCATE(ranks(comm_size))
154 IF (any(ranks /= (/ (i, i=0_xi,int(comm_size-1, xi)) /))) &
155 CALL test_abort(
"error in xt_xmap_get_destination_ranks", &
159 IF (any(ranks /= (/ (i, i=0_xi,int(comm_size-1, xi)) /))) &
160 CALL test_abort(
"error in xt_xmap_get_source_ranks", &
163 END SUBROUTINE check_allgather_analog_xmap
165 SUBROUTINE test_allgather_analog(xmap_new, num_indices_per_rank, comm)
167 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm)
RESULT(res)
168 IMPORT :: xt_idxlist, xt_xmap
170 TYPE(xt_idxlist),
INTENT(in) :: src_idxlist
171 TYPE(xt_idxlist),
INTENT(in) :: dst_idxlist
172 INTEGER,
VALUE,
INTENT(in) :: comm
174 END FUNCTION xmap_new
176 INTEGER,
INTENT(inout) :: comm
177 INTEGER,
INTENT(in) :: num_indices_per_rank
178 INTEGER(xi),
ALLOCATABLE :: src_index_list(:)
180 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
181 TYPE(xt_xmap) :: xmap, xmap_copy
182 TYPE(xt_stripe) :: dst_index_stripe(1)
183 INTEGER :: comm_size, comm_rank
184 INTEGER(xi) :: comm_rank_xi, num_indices_per_rank_xi
187 CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
188 comm_rank_xi = int(comm_rank, xi)
189 num_indices_per_rank_xi = int(num_indices_per_rank, xi)
191 ALLOCATE(src_index_list(num_indices_per_rank))
192 DO i = 1_xi, num_indices_per_rank
193 src_index_list(i) = comm_rank_xi * num_indices_per_rank_xi + i - 1_xi
196 dst_index_stripe(1) = xt_stripe(0, 1, comm_size * num_indices_per_rank)
198 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
203 CALL check_allgather_analog_xmap(xmap, comm)
205 CALL check_allgather_analog_xmap(xmap, comm)
210 END SUBROUTINE test_allgather_analog
212 SUBROUTINE check_ring_xmap(xmap, dst_index_list, is_inter)
213 TYPE(xt_xmap),
INTENT(in) :: xmap
214 INTEGER(xt_int_kind),
INTENT(in) :: dst_index_list(2)
215 LOGICAL,
INTENT(in) :: is_inter
216 INTEGER :: ranks(2), num_dst, num_src
218 IF (.NOT. is_inter .AND. (num_dst > 2 .OR. num_dst < 1)) &
219 CALL test_abort(
"error in xt_xmap_get_num_destinations", &
223 IF (num_src > 2 .OR. num_src < 1) &
224 CALL test_abort(
"error in xt_xmap_get_num_sources", filename, __line__)
226 IF (.NOT. is_inter)
THEN
228 CALL xt_sort_int(ranks(1:num_dst))
229 IF (any(ranks /= dst_index_list)) &
230 CALL test_abort(
"error in xt_xmap_get_destination_ranks", &
235 CALL xt_sort_int(ranks(1:num_src))
236 IF (any(ranks /= dst_index_list)) &
237 CALL test_abort(
"error in xt_xmap_get_source_ranks", &
239 END SUBROUTINE check_ring_xmap
241 SUBROUTINE test_ring_1d(xmap_new, comm)
243 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm)
RESULT(res)
244 IMPORT :: xt_idxlist, xt_xmap
246 TYPE(xt_idxlist),
INTENT(in) :: src_idxlist
247 TYPE(xt_idxlist),
INTENT(in) :: dst_idxlist
248 INTEGER,
VALUE,
INTENT(in) :: comm
250 END FUNCTION xmap_new
252 INTEGER,
INTENT(inout) :: comm
254 INTEGER(xt_int_kind) :: src_index_list(1), dst_index_list(2), temp
255 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
256 TYPE(xt_xmap) :: xmap, xmap_copy
257 INTEGER :: comm_size, comm_rank
260 CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
261 src_index_list(1) = int(comm_rank, xi)
265 dst_index_list(1) = int(mod(comm_rank + comm_size - 1, comm_size), xi)
266 dst_index_list(2) = int(mod(comm_rank + 1, comm_size), xi)
267 IF (dst_index_list(1) > dst_index_list(2))
THEN
268 temp = dst_index_list(1)
269 dst_index_list(1) = dst_index_list(2)
270 dst_index_list(2) = temp
275 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
280 CALL check_ring_xmap(xmap, dst_index_list, is_inter)
282 CALL check_ring_xmap(xmap_copy, dst_index_list, is_inter)
288 END SUBROUTINE test_ring_1d
290 SUBROUTINE test_maxpos(xmap_new, comm, indices_per_rank)
292 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm)
RESULT(res)
293 IMPORT :: xt_idxlist, xt_xmap
295 TYPE(xt_idxlist),
INTENT(in) :: src_idxlist
296 TYPE(xt_idxlist),
INTENT(in) :: dst_idxlist
297 INTEGER,
VALUE,
INTENT(in) :: comm
299 END FUNCTION xmap_new
301 INTEGER,
INTENT(in) :: comm
302 INTEGER,
INTENT(in) :: indices_per_rank
304 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
305 TYPE(xt_xmap) :: xmap, xmup, xmup2, xmsp
306 INTEGER :: indices_for_exch
307 INTEGER(xt_int_kind) :: src_index(indices_per_rank), &
308 dst_index(indices_per_rank)
309 INTEGER :: max_pos_src, max_pos_dst, max_pos_src_u, max_pos_dst_u, &
310 max_pos_src_u2, max_pos_dst_u2, max_pos_src_s, max_pos_dst_s
311 INTEGER :: comm_rank, comm_size, world_size
313 INTEGER :: i, xmspread(2)
314 INTEGER :: pos_update1(indices_per_rank), pos_update2(2*indices_per_rank)
316 CALL mpi_comm_rank(comm, comm_rank, ierror)
317 IF (ierror /= mpi_success) &
318 CALL test_abort(
"error calling mpi_comm_rank", filename, __line__)
319 CALL mpi_comm_size(comm, comm_size, ierror)
320 IF (ierror /= mpi_success) &
321 CALL test_abort(
"error calling mpi_comm_size", filename, __line__)
323 world_size = comm_size * indices_per_rank
326 indices_for_exch = indices_per_rank/2
327 DO i = 1, indices_per_rank
328 src_index(i) = int(i-1 + comm_rank * indices_per_rank, xi)
330 DO i = 1, indices_for_exch
331 dst_index(i) = int(mod(i - 1 - indices_for_exch &
332 + (comm_rank+comm_size) * indices_per_rank, world_size), xi)
334 DO i = indices_for_exch+1, indices_per_rank-indices_for_exch
335 dst_index(i) = int(i-1 + comm_rank * indices_per_rank, xi)
337 DO i = 1, indices_for_exch
338 dst_index(indices_per_rank-indices_for_exch+i) &
339 = int(mod(i + (comm_rank+1) * indices_per_rank, world_size), xi)
344 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
352 IF (max_pos_src < indices_per_rank-1) &
353 CALL test_abort(
"error in xt_xmap_get_max_src_pos", filename, __line__)
354 IF (max_pos_dst < indices_per_rank-1) &
355 CALL test_abort(
"error in xt_xmap_get_max_dst_pos", filename, __line__)
358 DO i = 1,indices_per_rank
359 pos_update1(i) = (i-1)*2
366 IF (max_pos_src_u < (indices_per_rank-1)*2) &
367 CALL test_abort(
"error in xt_xmap_get_max_src_pos", filename, __line__)
368 IF (max_pos_dst_u < (indices_per_rank-1)*2) &
369 CALL test_abort(
"error in xt_xmap_get_max_dst_pos", filename, __line__)
372 DO i = 1, indices_per_rank*2
373 pos_update2(i) = (i-1)/2
379 IF (max_pos_src_u2 >= indices_per_rank) &
380 CALL test_abort(
"error in xt_xmap_get_max_src_pos", filename, __line__)
381 IF (max_pos_dst_u2 >= indices_per_rank) &
382 CALL test_abort(
"error in xt_xmap_get_max_dst_pos", filename, __line__)
386 xmspread(2) = indices_per_rank*3
390 IF (max_pos_dst_s < (indices_per_rank-1)*3) &
391 CALL test_abort(
"error in xt_xmap_get_max_dst_pos", filename, __line__)
392 IF (max_pos_src_s < (indices_per_rank-1)*3) &
393 CALL test_abort(
"error in xt_xmap_get_max_src_pos", filename, __line__)
400 END SUBROUTINE test_maxpos
402 SUBROUTINE check_pair_xmap(xmap)
403 TYPE(xt_xmap),
INTENT(in) :: xmap
407 CALL test_abort(
"error in xt_xmap_get_num_destinations", &
411 CALL test_abort(
"error in xt_xmap_get_num_sources", filename, __line__)
414 IF (ranks(1) /= 0 .OR. ranks(2) /= 1) &
415 CALL test_abort(
"error in xt_xmap_get_destination_ranks", &
419 IF (ranks(1) /= 0 .OR. ranks(2) /= 1) &
420 CALL test_abort(
"error in xt_xmap_get_source_ranks", &
422 END SUBROUTINE check_pair_xmap
424 SUBROUTINE test_pair(xmap_new, comm)
426 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm)
RESULT(res)
427 IMPORT :: xt_idxlist, xt_xmap
429 TYPE(xt_idxlist),
INTENT(in) :: src_idxlist
430 TYPE(xt_idxlist),
INTENT(in) :: dst_idxlist
431 INTEGER,
VALUE,
INTENT(in) :: comm
433 END FUNCTION xmap_new
435 INTEGER,
INTENT(in) :: comm
437 INTEGER(xt_int_kind) :: i, j, k
439 INTEGER(xt_int_kind),
PARAMETER :: src_index_list(20, 0:1) = reshape((/ &
440 & 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, &
441 & 9_xi, 10_xi, 11_xi, 12_xi, 13_xi, &
442 & 17_xi, 18_xi, 19_xi, 20_xi, 21_xi, &
443 & 25_xi, 26_xi, 27_xi, 28_xi, 29_xi, &
444 & 4_xi, 5_xi, 6_xi, 7_xi, 8_xi, &
445 & 12_xi, 13_xi, 14_xi, 15_xi, 16_xi, &
446 & 20_xi, 21_xi, 22_xi, 23_xi, 24_xi, &
447 & 28_xi, 29_xi, 30_xi, 31_xi, 32_xi /), &
450 INTEGER(xt_int_kind),
PARAMETER :: src_index_list(20, 0:1) = reshape((/ &
451 (((i + j * 8_xi + k * 3_xi, i = 1_xi, 5_xi), j = 0_xi,3_xi), &
452 k = 0_xi,1_xi) /), (/ 20, 2 /))
455 INTEGER(xt_int_kind),
PARAMETER :: dst_index_list(20, 0:1) = reshape((/ &
456 10_xi, 15_xi, 14_xi, 13_xi, 12_xi, &
457 15_xi, 10_xi, 11_xi, 12_xi, 13_xi, &
458 23_xi, 18_xi, 19_xi, 20_xi, 21_xi, &
459 31_xi, 26_xi, 27_xi, 28_xi, 29_xi, &
460 13_xi, 12_xi, 11_xi, 10_xi, 15_xi, &
461 12_xi, 13_xi, 14_xi, 15_xi, 10_xi, &
462 20_xi, 21_xi, 22_xi, 23_xi, 18_xi, &
463 28_xi, 29_xi, 30_xi, 31_xi, 26_xi /), &
465 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
466 TYPE(xt_xmap) :: xmap, xmap_copy
467 INTEGER :: comm_rank, ierror
469 CALL mpi_comm_rank(comm, comm_rank, ierror)
470 IF (ierror /= mpi_success) &
471 CALL test_abort(
"error calling mpi_comm_rank", filename, __line__)
479 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
483 CALL check_pair_xmap(xmap)
485 CALL check_pair_xmap(xmap_copy)
490 END SUBROUTINE test_pair
492 SUBROUTINE check_ping_pong_xmap(xmap, comm, ping_rank, pong_rank)
493 TYPE(xt_xmap),
INTENT(in) :: xmap
494 INTEGER,
INTENT(in) :: comm, ping_rank, pong_rank
495 INTEGER :: expect, dst_rank(1), src_rank(1), comm_rank, ierror
496 CHARACTER(len=80) :: msg
498 CALL mpi_comm_rank(comm, comm_rank, ierror)
499 IF (ierror /= mpi_success) &
500 CALL test_abort(
'error calling mpi_comm_rank', filename, __line__)
501 WRITE (msg,
'(a,i0,a)')
"error in xt_xmap_get_num_destinations (rank == ", &
503 expect = merge(1, 0, comm_rank == ping_rank)
505 CALL test_abort(msg, filename, __line__)
507 expect = merge(1, 0, comm_rank == pong_rank)
509 CALL test_abort(msg, filename, __line__)
511 IF (comm_rank == ping_rank)
THEN
513 IF (dst_rank(1) /= pong_rank) &
514 CALL test_abort(
"error in xt_xmap_get_destination_ranks", &
517 IF (comm_rank == pong_rank)
THEN
519 IF (src_rank(1) /= ping_rank) &
520 CALL test_abort(
"error in xt_xmap_get_source_ranks", &
523 END SUBROUTINE check_ping_pong_xmap
525 SUBROUTINE test_ping_pong(xmap_new, comm, ping_rank, pong_rank)
527 FUNCTION xmap_new(src_idxlist, dst_idxlist, comm)
RESULT(res)
528 IMPORT :: xt_idxlist, xt_xmap
530 TYPE(xt_idxlist),
INTENT(in) :: src_idxlist
531 TYPE(xt_idxlist),
INTENT(in) :: dst_idxlist
532 INTEGER,
VALUE,
INTENT(in) :: comm
534 END FUNCTION xmap_new
536 INTEGER,
INTENT(in) :: ping_rank, pong_rank
537 INTEGER,
INTENT(inout) :: comm
538 INTEGER(xt_int_kind),
PARAMETER :: &
539 index_list(5) = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi /)
540 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
541 TYPE(xt_xmap) :: xmap, xmap_copy
542 INTEGER :: comm_rank, comm_size
544 CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
545 IF (comm_rank == ping_rank)
THEN
552 IF (comm_rank == pong_rank)
THEN
560 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
565 CALL check_ping_pong_xmap(xmap, comm, ping_rank, pong_rank)
567 CALL check_ping_pong_xmap(xmap_copy, comm, ping_rank, pong_rank)
571 END SUBROUTINE test_ping_pong
572 END MODULE test_xmap_common_parallel
void xt_initialize(MPI_Comm default_comm)
Xt_idxlist xt_idxempty_new(void)
void xt_idxlist_delete(Xt_idxlist idxlist)
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)
Xt_xmap xt_xmap_update_positions(Xt_xmap xmap, const int *src_positions, const int *dst_positions)
void xt_xmap_delete(Xt_xmap xmap)
Xt_xmap xt_xmap_spread(Xt_xmap xmap, int num_repetitions, const int src_displacements[num_repetitions], const int dst_displacements[num_repetitions])
int xt_xmap_get_num_destinations(Xt_xmap xmap)
Xt_xmap xt_xmap_copy(Xt_xmap xmap)
int xt_xmap_get_max_dst_pos(Xt_xmap xmap)
int xt_xmap_get_num_sources(Xt_xmap xmap)
void xt_xmap_get_source_ranks(Xt_xmap xmap, int *ranks)
void xt_xmap_get_destination_ranks(Xt_xmap xmap, int *ranks)
int xt_xmap_get_max_src_pos(Xt_xmap xmap)