45 PROGRAM test_xmap_intersection_parallel
46 USE ftest_common,
ONLY: init_mpi, finish_mpi, test_abort, posix_exit
48 USE iso_c_binding,
ONLY: c_int
49 USE test_idxlist_utils,
ONLY: test_err_count
61 xt_reorder_none, xt_reorder_send_up, xt_reorder_recv_up, &
63 #if defined __PGI && ( __PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 7))
68 USE yaxt,
ONLY: xt_is_null
74 INTEGER,
POINTER :: pos(:)
77 INTEGER,
PARAMETER :: xmi_type_base = 0, xmi_type_ext = 1
81 INTEGER :: my_rank, comm_size
82 CHARACTER(len=*),
PARAMETER :: &
83 filename =
'test_xmap_intersection_parallel_f.f90'
87 xmi_type = xmi_type_base
90 CALL mpi_comm_rank(mpi_comm_world, my_rank, ierror)
91 IF (ierror /= mpi_success) &
92 CALL test_abort(
"MPI error!", filename, __line__)
94 CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
95 IF (ierror /= mpi_success) &
96 CALL test_abort(
"MPI error!", filename, __line__)
98 IF (comm_size /= 3)
THEN
101 CALL posix_exit(77_c_int)
106 CALL elimination_test
107 CALL one_to_one_comm_test
108 CALL full_comm_matrix_test
111 CALL update_positions_and_spread_test
112 CALL alltoall_pos_test
114 IF (test_err_count() /= 0) &
115 CALL test_abort(
"non-zero error count!", filename, __line__)
121 SUBROUTINE simple_rr_test
123 INTEGER(xi) :: src_index(1), dst_index(1)
124 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
125 INTEGER,
PARAMETER :: num_src_intersections = 1, &
126 num_dst_intersections = 1, num_sends = 1, num_recvs = 1
127 INTEGER,
SAVE,
TARGET :: send_pos(num_sends) = (/ 0 /), &
128 recv_pos(num_recvs) = (/ 0 /)
129 TYPE(xt_com_list) :: src_com(num_src_intersections), &
130 dst_com(num_dst_intersections)
131 TYPE(xt_xmap) :: xmap
132 TYPE(test_message) :: send_messages(1), recv_messages(1)
134 src_index(1) = int(my_rank, xi)
135 dst_index(1) = int(mod(my_rank + 1, comm_size), xi)
138 src_com(1) = xt_com_list(src_idxlist, mod(my_rank+1, comm_size))
139 dst_com(1) = xt_com_list(dst_idxlist, mod(my_rank+comm_size-1, comm_size))
141 xmap = xmi_new(src_com(1:num_src_intersections), &
142 dst_com(1:num_dst_intersections), &
143 src_idxlist, dst_idxlist, mpi_comm_world)
146 send_messages(1)%rank = mod(my_rank+1, comm_size)
147 send_messages(1)%pos => send_pos
148 recv_messages(1)%rank = mod(my_rank+comm_size-1, comm_size)
149 recv_messages(1)%pos => recv_pos
151 CALL test_xmap(xmap, send_messages, recv_messages)
157 END SUBROUTINE simple_rr_test
160 SUBROUTINE elimination_test
161 INTEGER(xi),
PARAMETER :: src_index(1) = (/ 0_xi /), &
162 dst_index(1) = (/ 0_xi /)
163 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
164 INTEGER :: num_src_intersections, num_dst_intersections, num_sends, &
166 INTEGER,
TARGET :: send_pos(1), recv_pos(1)
167 TYPE(xt_com_list) :: src_com(1), dst_com(2)
168 TYPE(xt_xmap) :: xmap
169 TYPE(test_message) :: send_messages(1), recv_messages(1)
171 IF (my_rank == 0)
THEN
178 num_src_intersections = merge(1, 0, my_rank /= 0)
179 src_com = xt_com_list(src_idxlist, 0)
180 num_dst_intersections = merge(0, 2, my_rank /= 0)
181 dst_com(1) = xt_com_list(dst_idxlist, 1)
182 dst_com(2) = xt_com_list(dst_idxlist, 2)
184 xmap = xmi_new(src_com(1:num_src_intersections), &
185 dst_com(1:num_dst_intersections), &
186 src_idxlist, dst_idxlist, mpi_comm_world)
190 num_sends = merge(1, 0, my_rank == 1)
191 send_messages(1)%rank = 0
192 send_messages(1)%pos => send_pos
194 num_recvs = merge(1, 0, my_rank == 0)
195 recv_messages(1)%rank = 1
196 recv_messages(1)%pos => recv_pos
198 CALL test_xmap(xmap, send_messages(1:num_sends), recv_messages(1:num_recvs))
205 END SUBROUTINE elimination_test
208 SUBROUTINE one_to_one_comm_test
213 INTEGER(xi) :: src_indices(2), dst_index(1)
214 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist, src_intersection_idxlist(2)
215 INTEGER,
PARAMETER :: num_src_intersections(3) = (/ 2, 1, 0 /)
216 INTEGER :: num_sends, num_recvs, s_s, s_e, i
217 INTEGER,
TARGET :: send_pos(2), recv_pos(1)
218 TYPE(xt_com_list) :: src_com(2), dst_com(1)
219 TYPE(xt_xmap) :: xmap
220 TYPE(test_message) :: send_messages(2), recv_messages(1)
222 dst_index(1) = int(my_rank, xi)
224 src_indices(i) = int(mod(my_rank+i, comm_size), xi)
225 src_intersection_idxlist(i) =
xt_idxvec_new(src_indices(i:i), 1)
229 src_com(1) = xt_com_list(src_intersection_idxlist(1), 1)
230 src_com(2) = xt_com_list(src_intersection_idxlist(2), &
231 merge(2, 0, my_rank == 0))
232 dst_com = xt_com_list(dst_idxlist, merge(1, 0, my_rank == 0))
233 s_s = merge(my_rank + 1, 1, my_rank /= 2)
234 s_e = s_s + num_src_intersections(my_rank + 1) - 1
235 xmap = xmi_new(src_com(s_s:s_e), dst_com(:), src_idxlist, dst_idxlist, &
241 SELECT CASE (my_rank)
246 send_messages(1)%rank = 1
247 send_messages(1)%pos => send_pos(1:1)
248 send_messages(2)%rank = 2
249 send_messages(2)%pos => send_pos(2:2)
250 recv_messages(1)%rank = 1
254 send_messages(1)%rank = 0
255 send_messages(1)%pos => send_pos(1:1)
256 recv_messages(1)%rank = 0
259 recv_messages(1)%rank = 0
261 recv_messages(1)%pos => recv_pos(1:1)
262 CALL test_xmap(xmap, send_messages(1:num_sends), recv_messages(1:num_recvs))
270 END SUBROUTINE one_to_one_comm_test
273 SUBROUTINE full_comm_matrix_test
279 INTEGER(xi),
PARAMETER :: src_indices(5,0:2) &
280 = reshape((/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, &
281 & 3_xi, 4_xi ,5_xi, 6_xi, 7_xi, &
282 & 6_xi, 7_xi, 8_xi, 0_xi, 1_xi /), (/ 5, 3 /)), &
284 = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, 7_xi, 8_xi /)
285 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
286 TYPE(xt_com_list) :: src_com(0:2), dst_com(0:2)
287 TYPE(xt_xmap) :: xmap
288 INTEGER,
SAVE,
TARGET :: send_pos(5, 0:2) &
289 = reshape((/ 0,1,2,3,4, 2,3,4,-1,-1, 2,-1,-1,-1,-1 /), (/ 5, 3 /)), &
290 num_send_pos(0:2) = (/ 5, 3, 1 /), &
292 = reshape((/ 0,1,2,3,4, 5,6,7,-1,-1, 8,-1,-1,-1,-1 /), (/ 5, 3 /)), &
293 num_recv_pos(0:2) = (/ 5, 3, 1 /)
294 TYPE(test_message) :: send_messages(0:2), recv_messages(0:2)
301 src_com(i) = xt_com_list(src_idxlist, i)
302 dst_com(i) = xt_com_list(
xt_idxvec_new(src_indices(:, i)), i)
304 xmap = xmi_new(src_com, dst_com, src_idxlist, dst_idxlist, &
309 send_messages(i)%rank = i
310 send_messages(i)%pos => send_pos(1:num_send_pos(my_rank), my_rank)
311 recv_messages(i)%rank = i
312 recv_messages(i)%pos => recv_pos(1:num_recv_pos(i), i)
314 CALL test_xmap(xmap, send_messages, recv_messages)
323 END SUBROUTINE full_comm_matrix_test
327 SUBROUTINE dedup_test
332 INTEGER(xt_int_kind),
PARAMETER :: src_indices(2, 0:1) &
333 = reshape((/ 0_xi,2_xi, 1_xi,2_xi /), (/ 2, 2 /))
334 TYPE(xt_com_list) :: src_com(1), dst_com(2)
335 INTEGER :: num_src_intersections, num_dst_intersections
336 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
337 INTEGER(xt_int_kind),
PARAMETER :: dst_indices(3) = (/ 0_xi, 1_xi, 2_xi /)
338 TYPE(xt_xmap) :: xmap
339 INTEGER :: i, num_recv_messages, num_send_messages
340 INTEGER,
PARAMETER :: num_recv_pos(2) = (/ 2, 1 /), &
341 num_send_pos(2) = (/ 2, 1 /)
342 INTEGER,
SAVE,
TARGET :: &
343 recv_pos(2, 2) = reshape((/ 0, 2, 1, -1 /), (/ 2, 2 /)), &
344 send_pos(2, 2) = reshape((/ 0, 1, 0, -1 /), (/ 2, 2 /))
345 TYPE(test_message) :: recv_messages(2), send_messages(1)
347 IF (my_rank == 2)
THEN
348 num_src_intersections = 0
349 num_dst_intersections = 2
352 dst_com(i+1)%rank = i
357 num_src_intersections = 1
360 num_dst_intersections = 0;
364 xmap = xmi_new(src_com(1:num_src_intersections), &
365 dst_com(1:num_dst_intersections), &
366 src_idxlist, dst_idxlist, mpi_comm_world)
369 IF (my_rank == 2)
THEN
370 num_recv_messages = 2
371 num_send_messages = 0
373 recv_messages(i)%rank = i - 1
374 recv_messages(i)%pos => recv_pos(1:num_recv_pos(i), i)
377 num_recv_messages = 0
378 num_send_messages = 1
379 send_messages(1)%rank = 2
380 send_messages(1)%pos => send_pos(1:num_send_pos(my_rank + 1), my_rank + 1)
382 CALL test_xmap(xmap, send_messages(1:num_send_messages), &
383 recv_messages(1:num_recv_messages))
391 END SUBROUTINE dedup_test
394 SUBROUTINE reorder_test
396 INTEGER(xt_int_kind),
PARAMETER :: src_indices(6) &
397 = (/ 0_xi, 5_xi, 1_xi, 4_xi, 2_xi, 3_xi /)
398 INTEGER(xt_int_kind),
PARAMETER :: dst_indices(6) &
399 = (/ 5_xi, 4_xi, 3_xi, 2_xi, 1_xi, 0_xi /)
400 INTEGER(xt_int_kind),
PARAMETER :: intersection_indices(6) &
401 = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, 5_xi /)
402 TYPE(xt_com_list) :: src_com(1), dst_com(1)
403 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
404 TYPE(xt_xmap) :: xmap, xmap_reorder
405 INTEGER(xt_reorder_type_kind),
PARAMETER :: reorder_types(3) &
406 = (/ xt_reorder_none, xt_reorder_send_up, xt_reorder_recv_up/)
408 INTEGER,
SAVE,
TARGET :: send_pos(6), recv_pos(6)
409 TYPE(test_message) :: recv_messages(1), send_messages(1)
415 src_com(1)%rank = mod(my_rank + 1, comm_size)
417 dst_com(1)%rank = mod(comm_size + my_rank - 1, comm_size)
418 xmap = xmi_new(src_com, dst_com, src_idxlist, dst_idxlist, mpi_comm_world)
420 send_messages(1)%rank = mod(my_rank + 1, comm_size)
421 send_messages(1)%pos => send_pos
422 recv_messages(1)%rank = mod(comm_size + my_rank - 1, comm_size)
423 recv_messages(1)%pos => recv_pos
428 send_pos = (/ 0, 2, 4, 5, 3, 1 /)
429 recv_pos = (/ 5, 4, 3, 2, 1, 0 /)
430 SELECT CASE(reorder_types(i))
431 CASE(xt_reorder_send_up)
432 CALL xt_sort_permutation(send_pos, recv_pos)
433 CASE(xt_reorder_recv_up)
434 CALL xt_sort_permutation(recv_pos, send_pos)
436 CALL test_xmap(xmap_reorder, send_messages, recv_messages)
446 END SUBROUTINE reorder_test
449 SUBROUTINE update_positions_and_spread_test
451 INTEGER(xt_int_kind),
PARAMETER :: indices(12) &
452 = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, 7_xi, 8_xi, 9_xi, 10_xi, 11_xi /)
453 TYPE(xt_com_list) :: src_com(1), dst_com(1)
454 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
455 TYPE(xt_xmap) :: xmap, xmap_single_level_blocked, xmap_multi_level_blocked
456 INTEGER :: i, idx, blk, lev
457 INTEGER,
PARAMETER :: nproma = 4, nblk = 3, nlev = 6
458 INTEGER,
SAVE,
TARGET :: blocked_positions(72)
459 INTEGER :: displacements(6)
460 TYPE(test_message) :: recv_messages(1), send_messages(1)
466 src_com(1)%rank = mod(my_rank + 1, comm_size)
468 dst_com(1)%rank = mod(comm_size + my_rank - 1, comm_size)
469 xmap = xmi_new(src_com, dst_com, src_idxlist, dst_idxlist, mpi_comm_world)
474 DO idx = 0, nproma - 1
475 blocked_positions(i) = idx + (blk * nlev + lev) * nproma
481 displacements(i) = (i - 1) * nproma
484 xmap_single_level_blocked = &
486 xmap_multi_level_blocked = &
488 xmap_single_level_blocked, nlev, displacements, displacements);
490 send_messages(1)%rank = mod(my_rank + 1, comm_size)
491 send_messages(1)%pos => blocked_positions
492 recv_messages(1)%rank = mod(comm_size + my_rank - 1, comm_size)
493 recv_messages(1)%pos => blocked_positions
496 CALL test_xmap(xmap_multi_level_blocked, send_messages, recv_messages)
506 END SUBROUTINE update_positions_and_spread_test
509 SUBROUTINE alltoall_pos_test
511 TYPE(xt_xmap) :: xmap
512 TYPE(xt_com_pos),
TARGET :: src_com(comm_size), dst_com(comm_size)
513 INTEGER,
TARGET :: transfer_pos(comm_size)
514 TYPE(test_message) :: recv_messages(comm_size), send_messages(comm_size)
519 src_com(i)%transfer_pos => transfer_pos(i:i)
520 src_com(i)%rank = i - 1
521 dst_com(i)%transfer_pos => transfer_pos(i:i)
522 dst_com(i)%rank = i - 1
523 send_messages(i)%rank = i - 1
524 send_messages(i)%pos => transfer_pos(i:i)
525 recv_messages(i)%rank = i - 1
526 recv_messages(i)%pos => transfer_pos(i:i)
532 CALL test_xmap(xmap, send_messages, recv_messages)
536 END SUBROUTINE alltoall_pos_test
538 SUBROUTINE test_xmap_iter(iter, msgs)
539 TYPE(xt_xmap_iter),
INTENT(inout) :: iter
540 TYPE(test_message),
INTENT(in) :: msgs(:)
542 INTEGER :: num_msgs, num_pos, i, j
543 INTEGER,
POINTER :: pos(:)
544 LOGICAL :: iter_is_null
546 num_msgs =
SIZE(msgs)
547 iter_is_null = xt_is_null(iter)
548 IF (num_msgs == 0)
THEN
549 IF (.NOT. iter_is_null) &
550 CALL test_abort(
'ERROR: xt_xmap_get_*_iterator (non-null when &
551 &iter should be null)', &
553 ELSE IF (iter_is_null)
THEN
554 CALL test_abort(
'ERROR: xt_xmap_get_*_iterator &
555 &(iter should not be NULL)', &
561 CALL test_abort(
'ERROR: xt_xmap_iterator_get_rank', &
563 num_pos =
SIZE(msgs(i)%pos)
565 CALL test_abort(
"ERROR: xt_xmap_iterator_get_num_transfer_pos", &
570 IF (pos(j) /= msgs(i)%pos(j)) &
571 CALL test_abort(
'ERROR: xt_xmap_iterator_get_transfer_pos', &
578 CALL test_abort(
'ERROR: xt_xmap_iterator_next &
579 &(wrong number of messages)', &
582 END SUBROUTINE test_xmap_iter
584 SUBROUTINE test_xmap(xmap, send_messages, recv_messages)
585 TYPE(xt_xmap),
INTENT(in) :: xmap
586 TYPE(test_message),
INTENT(in) :: send_messages(:), recv_messages(:)
588 INTEGER :: num_sends, num_recvs
589 TYPE(xt_xmap_iter) :: send_iter, recv_iter
590 INTEGER,
PARAMETER :: num_xmaps_2_test = 2
592 TYPE(xt_xmap) :: maps(num_xmaps_2_test)
596 DO i = 1, num_xmaps_2_test
597 num_sends =
SIZE(send_messages)
598 num_recvs =
SIZE(recv_messages)
600 CALL test_abort(
'ERROR: xt_xmap_get_num_destinations', filename, &
603 CALL test_abort(
'ERROR: xt_xmap_get_num_sources', filename, __line__)
607 CALL test_xmap_iter(send_iter, send_messages)
608 CALL test_xmap_iter(recv_iter, recv_messages)
614 END SUBROUTINE test_xmap
616 SUBROUTINE parse_options
617 INTEGER :: i, num_cmd_args, arg_len
618 INTEGER,
PARAMETER :: max_opt_arg_len = 80
619 CHARACTER(max_opt_arg_len) :: optarg
620 num_cmd_args = command_argument_count()
622 DO WHILE (i < num_cmd_args)
623 CALL get_command_argument(i, optarg, arg_len)
624 IF (optarg(1:2) ==
'-m' .AND. i < num_cmd_args .AND. arg_len == 2)
THEN
625 CALL get_command_argument(i + 1, optarg, arg_len)
626 IF (arg_len > max_opt_arg_len) &
627 CALL test_abort(
'incorrect argument to command-line option -m', &
629 IF (optarg(1:arg_len) ==
"xt_xmap_intersection_new")
THEN
630 xmi_type = xmi_type_base
631 ELSE IF (optarg(1:arg_len) ==
"xt_xmap_intersection_ext_new")
THEN
632 xmi_type = xmi_type_ext
634 WRITE (0, *)
'arg to -m: ', optarg(1:arg_len)
635 CALL test_abort(
'incorrect argument to command-line option -m', &
640 WRITE (0, *)
'unexpected command-line argument parsing error: ', &
643 CALL test_abort(
'unexpected command-line argument -m', filename, &
647 END SUBROUTINE parse_options
649 FUNCTION xmi_new(src_com, dst_com, src_idxlist, dst_idxlist, comm) &
651 TYPE(xt_com_list),
INTENT(in) :: src_com(:), dst_com(:)
652 TYPE(xt_idxlist),
INTENT(in) :: src_idxlist, dst_idxlist
653 INTEGER,
INTENT(in) :: comm
654 TYPE(xt_xmap) :: xmap
655 SELECT CASE(xmi_type)
658 src_idxlist, dst_idxlist, comm)
661 src_idxlist, dst_idxlist, comm)
665 END PROGRAM test_xmap_intersection_parallel
void xt_initialize(MPI_Comm default_comm)
Xt_idxlist xt_idxempty_new(void)
void xt_idxlist_delete(Xt_idxlist idxlist)
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)
int xt_xmap_iterator_next(Xt_xmap_iter iter)
Xt_xmap xt_xmap_reorder(Xt_xmap xmap, enum xt_reorder_type type)
void xt_xmap_delete(Xt_xmap xmap)
Xt_xmap_iter xt_xmap_get_out_iterator(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 const * xt_xmap_iterator_get_transfer_pos(Xt_xmap_iter iter)
void xt_xmap_iterator_delete(Xt_xmap_iter iter)
int xt_xmap_get_num_destinations(Xt_xmap xmap)
Xt_xmap xt_xmap_copy(Xt_xmap xmap)
int xt_xmap_iterator_get_rank(Xt_xmap_iter iter)
int xt_xmap_get_num_sources(Xt_xmap xmap)
Xt_xmap_iter xt_xmap_get_in_iterator(Xt_xmap xmap)
int xt_xmap_iterator_get_num_transfer_pos(Xt_xmap_iter iter)
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)