1
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
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
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)
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
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
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
103 CALL test_maxpos(xmap_new, comm, 5)
104
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__)
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)
146 CALL test_abort("error in xmap construction", filename, __line__)
147
149 CALL test_abort("error in xt_xmap_get_num_sources", &
150 filename, __line__)
151
152 ALLOCATE(ranks(comm_size))
153
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
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)
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
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
197 dst_index_stripe(1) =
xt_stripe(0, 1, comm_size * num_indices_per_rank)
199 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
202
203
204 CALL check_allgather_analog_xmap(xmap, comm)
206 CALL check_allgather_analog_xmap(xmap, comm)
207
208
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
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
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
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
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)
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
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)
264
265
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
274
275
276 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
279
280
281 CALL check_ring_xmap(xmap, dst_index_list, is_inter)
283 CALL check_ring_xmap(xmap_copy, dst_index_list, is_inter)
284
285
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)
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
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
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
344
345 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
348
349
350
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
359 DO i = 1,indices_per_rank
360 pos_update1(i) = (i-1)*2
361 END DO
362
364
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
373 DO i = 1, indices_per_rank*2
374 pos_update2(i) = (i-1)/2
375 END DO
377
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
386 xmspread(1) = 0
387 xmspread(2) = indices_per_rank*3
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
401 END SUBROUTINE test_maxpos
402
403 SUBROUTINE check_pair_xmap(xmap)
404 TYPE(xt_xmap), INTENT(in) :: xmap
405 INTEGER :: ranks(2)
406
408 CALL test_abort("error in xt_xmap_get_num_destinations", &
409 filename, __line__)
410
412 CALL test_abort("error in xt_xmap_get_num_sources", filename, __line__)
413
415 IF (ranks(1) /= 0 .OR. ranks(2) /= 1) &
416 CALL test_abort("error in xt_xmap_get_destination_ranks", &
417 filename, __line__)
418
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)
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
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
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
475
476
478
479
480 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
483
484 CALL check_pair_xmap(xmap)
486 CALL check_pair_xmap(xmap_copy)
487
488
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)
506 CALL test_abort(msg, filename, __line__)
507
508 expect = merge(1, 0, comm_rank == pong_rank)
510 CALL test_abort(msg, filename, __line__)
511
512 IF (comm_rank == ping_rank) THEN
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
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)
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
548 ELSE
550 END IF
551
552
553 IF (comm_rank == pong_rank) THEN
555 ELSE
557 END IF
558
559
560
561 xmap = xmap_new(src_idxlist, dst_idxlist, comm)
564
565
566 CALL check_ping_pong_xmap(xmap, comm, ping_rank, pong_rank)
568 CALL check_ping_pong_xmap(xmap_copy, comm, ping_rank, pong_rank)
569
572 END SUBROUTINE test_ping_pong
573END MODULE test_xmap_common_parallel
574
575
576
577
578
579
580
581
582
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)