Yet Another eXchange Tool  0.9.0
test_xmap_common_parallel_f.f90
1 
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://doc.redmine.dkrz.de/yaxt/html/
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 MODULE test_xmap_common_parallel
47  USE mpi
48  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
49  USE test_idxlist_utils, ONLY: test_err_count
50  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, xt_stripe, &
51  xi => xt_int_kind, xt_sort_int, &
52  xt_idxlist, xt_idxlist_delete, xt_idxvec_new, &
54  xt_xmap, xt_xmap_copy, xt_xmap_delete, &
59  IMPLICIT NONE
60  PRIVATE
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'
67 CONTAINS
68  SUBROUTINE xmap_parallel_test_main(xmap_new)
69  INTERFACE
70  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
71  IMPORT :: xt_idxlist, xt_xmap
72  IMPLICIT NONE
73  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
74  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
75  INTEGER, VALUE, INTENT(in) :: comm
76  TYPE(xt_xmap) :: res
77  END FUNCTION xmap_new
78  END INTERFACE
79  INTEGER :: comm, comm_rank, comm_size
80  INTEGER :: ierror
81  CALL init_mpi
82  comm = mpi_comm_world
83  CALL xt_initialize(comm)
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", &
92  filename, __line__)
93 
94  CALL test_allgather_analog(xmap_new, 1, comm)
95  ! repeat test for large index list that will cause stripifying
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)
100 
101  ! test maxpos implementation for xt_xmap_intersection
102  CALL test_maxpos(xmap_new, comm, 5)
103  ! test maxpos implementation for xt_xmap_intersection_ext
104  CALL test_maxpos(xmap_new, comm, 501)
105 
106  IF (test_err_count() /= 0) &
107  CALL test_abort("non-zero error count!", filename, __line__)
108  CALL xt_finalize
109  CALL finish_mpi
110  END SUBROUTINE xmap_parallel_test_main
111 
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
116  INTEGER :: ierror
117 
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", &
124  filename, __line__)
125  IF (is_inter) THEN
126  CALL mpi_comm_remote_size(comm, comm_size, ierror)
127  ELSE
128  CALL mpi_comm_size(comm, comm_size, ierror)
129  END IF
130  IF (ierror /= mpi_success) &
131  CALL test_abort("error calling mpi_comm_(remote)_size", &
132  filename, __line__)
133  END SUBROUTINE get_rank_range
134 
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
141  LOGICAL :: is_inter
142 
143  CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
144  IF (xt_xmap_get_num_destinations(xmap) /= int(comm_size, xi)) &
145  CALL test_abort("error in xmap construction", filename, __line__)
146 
147  IF (xt_xmap_get_num_sources(xmap) /= int(comm_size, xi)) &
148  CALL test_abort("error in xt_xmap_get_num_sources", &
149  filename, __line__)
150 
151  ALLOCATE(ranks(comm_size))
152 
153  CALL xt_xmap_get_destination_ranks(xmap, ranks)
154  IF (any(ranks /= (/ (i, i=0_xi,int(comm_size-1, xi)) /))) &
155  CALL test_abort("error in xt_xmap_get_destination_ranks", &
156  filename, __line__)
157 
158  CALL xt_xmap_get_source_ranks(xmap, 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", &
161  filename, __line__)
162  DEALLOCATE(ranks)
163  END SUBROUTINE check_allgather_analog_xmap
164 
165  SUBROUTINE test_allgather_analog(xmap_new, num_indices_per_rank, comm)
166  INTERFACE
167  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
168  IMPORT :: xt_idxlist, xt_xmap
169  IMPLICIT NONE
170  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
171  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
172  INTEGER, VALUE, INTENT(in) :: comm
173  TYPE(xt_xmap) :: res
174  END FUNCTION xmap_new
175  END INTERFACE
176  INTEGER, INTENT(inout) :: comm
177  INTEGER, INTENT(in) :: num_indices_per_rank
178  INTEGER(xi), ALLOCATABLE :: src_index_list(:)
179  INTEGER(xi) :: i
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
185  LOGICAL :: is_inter
186 
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)
190  ! setup
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
194  END DO
195  src_idxlist = xt_idxvec_new(src_index_list)
196  dst_index_stripe(1) = xt_stripe(0, 1, comm_size * num_indices_per_rank)
197  dst_idxlist = xt_idxstripes_new(dst_index_stripe)
198  xmap = xmap_new(src_idxlist, dst_idxlist, comm)
199  CALL xt_idxlist_delete(src_idxlist)
200  CALL xt_idxlist_delete(dst_idxlist)
201 
202  ! verify expected results
203  CALL check_allgather_analog_xmap(xmap, comm)
204  xmap_copy = xt_xmap_copy(xmap)
205  CALL check_allgather_analog_xmap(xmap, comm)
206 
207  ! clean up
208  CALL xt_xmap_delete(xmap)
209  CALL xt_xmap_delete(xmap_copy)
210  END SUBROUTINE test_allgather_analog
211 
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
217  num_dst = xt_xmap_get_num_destinations(xmap)
218  IF (.NOT. is_inter .AND. (num_dst > 2 .OR. num_dst < 1)) &
219  CALL test_abort("error in xt_xmap_get_num_destinations", &
220  filename, __line__)
221 
222  num_src = xt_xmap_get_num_sources(xmap)
223  IF (num_src > 2 .OR. num_src < 1) &
224  CALL test_abort("error in xt_xmap_get_num_sources", filename, __line__)
225 
226  IF (.NOT. is_inter) THEN
227  CALL xt_xmap_get_destination_ranks(xmap, ranks)
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", &
231  filename, __line__)
232  END IF
233 
234  CALL xt_xmap_get_source_ranks(xmap, 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", &
238  filename, __line__)
239  END SUBROUTINE check_ring_xmap
240 
241  SUBROUTINE test_ring_1d(xmap_new, comm)
242  INTERFACE
243  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
244  IMPORT :: xt_idxlist, xt_xmap
245  IMPLICIT NONE
246  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
247  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
248  INTEGER, VALUE, INTENT(in) :: comm
249  TYPE(xt_xmap) :: res
250  END FUNCTION xmap_new
251  END INTERFACE
252  INTEGER, INTENT(inout) :: comm
253  ! test in which each process talks WITH two other processes
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
258  LOGICAL :: is_inter
259 
260  CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
261  src_index_list(1) = int(comm_rank, xi)
262  src_idxlist = xt_idxvec_new(src_index_list)
263 
264  ! destination index list
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
271  END IF
272  dst_idxlist = xt_idxvec_new(dst_index_list, 2)
273 
274  ! test of exchange map
275  xmap = xmap_new(src_idxlist, dst_idxlist, comm)
276  CALL xt_idxlist_delete(src_idxlist)
277  CALL xt_idxlist_delete(dst_idxlist)
278 
279  ! test results
280  CALL check_ring_xmap(xmap, dst_index_list, is_inter)
281  xmap_copy = xt_xmap_copy(xmap)
282  CALL check_ring_xmap(xmap_copy, dst_index_list, is_inter)
283 
284  ! clean up
285  CALL xt_xmap_delete(xmap)
286  CALL xt_xmap_delete(xmap_copy)
287 
288  END SUBROUTINE test_ring_1d
289 
290  SUBROUTINE test_maxpos(xmap_new, comm, indices_per_rank)
291  INTERFACE
292  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
293  IMPORT :: xt_idxlist, xt_xmap
294  IMPLICIT NONE
295  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
296  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
297  INTEGER, VALUE, INTENT(in) :: comm
298  TYPE(xt_xmap) :: res
299  END FUNCTION xmap_new
300  END INTERFACE
301  INTEGER, INTENT(in) :: comm
302  INTEGER, INTENT(in) :: indices_per_rank
303  ! first setup simple pattern of boundary exchange
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
312  INTEGER :: ierror
313  INTEGER :: i, xmspread(2)
314  INTEGER :: pos_update1(indices_per_rank), pos_update2(2*indices_per_rank)
315 
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__)
322 
323  world_size = comm_size * indices_per_rank
324 
325  ! setup
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)
329  END DO
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)
333  END DO
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)
336  END DO
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)
340  END DO
341  src_idxlist = xt_idxvec_new(src_index)
342  dst_idxlist = xt_idxvec_new(dst_index)
343 
344  xmap = xmap_new(src_idxlist, dst_idxlist, comm)
345  CALL xt_idxlist_delete(src_idxlist)
346  CALL xt_idxlist_delete(dst_idxlist)
347 
348  ! test
349  ! 1. test that initial max positions are in range
350  max_pos_dst = xt_xmap_get_max_dst_pos(xmap)
351  max_pos_src = xt_xmap_get_max_src_pos(xmap)
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__)
356 
357  ! 2. expand range and verify it is reflected in max pos
358  DO i = 1,indices_per_rank
359  pos_update1(i) = (i-1)*2
360  END DO
361 
362  xmup = xt_xmap_update_positions(xmap, pos_update1, pos_update1)
363 
364  max_pos_dst_u = xt_xmap_get_max_dst_pos(xmup)
365  max_pos_src_u = xt_xmap_get_max_src_pos(xmup)
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__)
370 
371  ! 3. contract range again and verify max pos is updated
372  DO i = 1, indices_per_rank*2
373  pos_update2(i) = (i-1)/2
374  END DO
375  xmup2 = xt_xmap_update_positions(xmap, pos_update2, pos_update2)
376 
377  max_pos_dst_u2 = xt_xmap_get_max_dst_pos(xmup2)
378  max_pos_src_u2 = xt_xmap_get_max_src_pos(xmup2)
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__)
383 
384  ! 4. apply spread and check max pos range
385  xmspread(1) = 0
386  xmspread(2) = indices_per_rank*3
387  xmsp = xt_xmap_spread(xmap, 2, xmspread, xmspread)
388  max_pos_dst_s = xt_xmap_get_max_dst_pos(xmsp)
389  max_pos_src_s = xt_xmap_get_max_src_pos(xmsp)
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__)
394 
395  ! cleanup
396  CALL xt_xmap_delete(xmap)
397  CALL xt_xmap_delete(xmup)
398  CALL xt_xmap_delete(xmup2)
399  CALL xt_xmap_delete(xmsp)
400  END SUBROUTINE test_maxpos
401 
402  SUBROUTINE check_pair_xmap(xmap)
403  TYPE(xt_xmap), INTENT(in) :: xmap
404  INTEGER :: ranks(2)
405  ! test results
406  IF (xt_xmap_get_num_destinations(xmap) /= 2) &
407  CALL test_abort("error in xt_xmap_get_num_destinations", &
408  filename, __line__)
409 
410  IF (xt_xmap_get_num_sources(xmap) /= 2) &
411  CALL test_abort("error in xt_xmap_get_num_sources", filename, __line__)
412 
413  CALL xt_xmap_get_destination_ranks(xmap, ranks)
414  IF (ranks(1) /= 0 .OR. ranks(2) /= 1) &
415  CALL test_abort("error in xt_xmap_get_destination_ranks", &
416  filename, __line__)
417 
418  CALL xt_xmap_get_source_ranks(xmap, ranks)
419  IF (ranks(1) /= 0 .OR. ranks(2) /= 1) &
420  CALL test_abort("error in xt_xmap_get_source_ranks", &
421  filename, __line__)
422  END SUBROUTINE check_pair_xmap
423 
424  SUBROUTINE test_pair(xmap_new, comm)
425  INTERFACE
426  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
427  IMPORT :: xt_idxlist, xt_xmap
428  IMPLICIT NONE
429  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
430  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
431  INTEGER, VALUE, INTENT(in) :: comm
432  TYPE(xt_xmap) :: res
433  END FUNCTION xmap_new
434  END INTERFACE
435  INTEGER, INTENT(in) :: comm
436  !src_index_list(index, rank)
437  INTEGER(xt_int_kind) :: i, j, k
438 #ifdef __xlC__
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 /), &
448  (/ 20, 2 /))
449 #else
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 /))
453 #endif
454  ! dst_index_list(index,rank)
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 /), &
464  (/ 20, 2 /))
465  TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
466  TYPE(xt_xmap) :: xmap, xmap_copy
467  INTEGER :: comm_rank, ierror
468 
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__)
472 
473  src_idxlist = xt_idxvec_new(src_index_list(:, comm_rank))
474 
475  ! destination index list
476  dst_idxlist = xt_idxvec_new(dst_index_list(:, comm_rank))
477 
478  ! test of exchange map
479  xmap = xmap_new(src_idxlist, dst_idxlist, comm)
480  CALL xt_idxlist_delete(src_idxlist)
481  CALL xt_idxlist_delete(dst_idxlist)
482 
483  CALL check_pair_xmap(xmap)
484  xmap_copy = xt_xmap_copy(xmap)
485  CALL check_pair_xmap(xmap_copy)
486 
487  ! clean up
488  CALL xt_xmap_delete(xmap)
489  CALL xt_xmap_delete(xmap_copy)
490  END SUBROUTINE test_pair
491 
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
497 
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 == ", &
502  comm_rank, ")"
503  expect = merge(1, 0, comm_rank == ping_rank)
504  IF (xt_xmap_get_num_destinations(xmap) /= expect) &
505  CALL test_abort(msg, filename, __line__)
506 
507  expect = merge(1, 0, comm_rank == pong_rank)
508  IF (xt_xmap_get_num_sources(xmap) /= expect) &
509  CALL test_abort(msg, filename, __line__)
510 
511  IF (comm_rank == ping_rank) THEN
512  CALL xt_xmap_get_destination_ranks(xmap, dst_rank)
513  IF (dst_rank(1) /= pong_rank) &
514  CALL test_abort("error in xt_xmap_get_destination_ranks", &
515  filename, __line__)
516  END IF
517  IF (comm_rank == pong_rank) THEN
518  CALL xt_xmap_get_source_ranks(xmap, src_rank)
519  IF (src_rank(1) /= ping_rank) &
520  CALL test_abort("error in xt_xmap_get_source_ranks", &
521  filename, __line__)
522  END IF
523  END SUBROUTINE check_ping_pong_xmap
524 
525  SUBROUTINE test_ping_pong(xmap_new, comm, ping_rank, pong_rank)
526  INTERFACE
527  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
528  IMPORT :: xt_idxlist, xt_xmap
529  IMPLICIT NONE
530  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
531  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
532  INTEGER, VALUE, INTENT(in) :: comm
533  TYPE(xt_xmap) :: res
534  END FUNCTION xmap_new
535  END INTERFACE
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
543  LOGICAL :: is_inter
544  CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
545  IF (comm_rank == ping_rank) THEN
546  src_idxlist = xt_idxvec_new(index_list)
547  ELSE
548  src_idxlist = xt_idxempty_new()
549  END IF
550 
551 
552  IF (comm_rank == pong_rank) THEN
553  dst_idxlist = xt_idxvec_new(index_list)
554  ELSE
555  dst_idxlist = xt_idxempty_new()
556  END IF
557 
558  ! test of exchange map
559 
560  xmap = xmap_new(src_idxlist, dst_idxlist, comm)
561  CALL xt_idxlist_delete(src_idxlist)
562  CALL xt_idxlist_delete(dst_idxlist)
563 
564  ! test results
565  CALL check_ping_pong_xmap(xmap, comm, ping_rank, pong_rank)
566  xmap_copy = xt_xmap_copy(xmap)
567  CALL check_ping_pong_xmap(xmap_copy, comm, ping_rank, pong_rank)
568  ! clean up
569  CALL xt_xmap_delete(xmap)
570  CALL xt_xmap_delete(xmap_copy)
571  END SUBROUTINE test_ping_pong
572 END MODULE test_xmap_common_parallel
573 !
574 ! Local Variables:
575 ! f90-continuation-indent: 5
576 ! coding: utf-8
577 ! indent-tabs-mode: nil
578 ! show-trailing-whitespace: t
579 ! require-trailing-newline: t
580 ! End:
581 !
Definition: yaxt.f90:49
void xt_initialize(MPI_Comm default_comm)
Definition: xt_init.c:70
void xt_finalize(void)
Definition: xt_init.c:89
Xt_idxlist xt_idxempty_new(void)
Definition: xt_idxempty.c:165
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition: xt_idxlist.c:74
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:163
Xt_xmap xt_xmap_update_positions(Xt_xmap xmap, const int *src_positions, const int *dst_positions)
Definition: xt_xmap.c:146
void xt_xmap_delete(Xt_xmap xmap)
Definition: xt_xmap.c:85
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:151
int xt_xmap_get_num_destinations(Xt_xmap xmap)
Definition: xt_xmap.c:60
Xt_xmap xt_xmap_copy(Xt_xmap xmap)
Definition: xt_xmap.c:80
int xt_xmap_get_max_dst_pos(Xt_xmap xmap)
Definition: xt_xmap.c:138
int xt_xmap_get_num_sources(Xt_xmap xmap)
Definition: xt_xmap.c:65
void xt_xmap_get_source_ranks(Xt_xmap xmap, int *ranks)
Definition: xt_xmap.c:75
void xt_xmap_get_destination_ranks(Xt_xmap xmap, int *ranks)
Definition: xt_xmap.c:70
int xt_xmap_get_max_src_pos(Xt_xmap xmap)
Definition: xt_xmap.c:134