Yet Another eXchange Tool  DO_NOT_EDIT_HERE
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, &
53  xt_idxstripes_new, xt_idxempty_new, &
54  xt_xmap, xt_xmap_copy, xt_xmap_delete, &
55  xt_xmap_get_num_destinations, xt_xmap_get_num_sources, &
56  xt_xmap_get_destination_ranks, xt_xmap_get_source_ranks
57  IMPLICIT NONE
58  PRIVATE
59  PUBLIC :: xmap_parallel_test_main
60  PUBLIC :: get_rank_range
61  PUBLIC :: check_allgather_analog_xmap
62  PUBLIC :: test_ring_1d
63  PUBLIC :: test_ping_pong
64 CONTAINS
65  SUBROUTINE xmap_parallel_test_main(xmap_new)
66  INTERFACE
67  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
68  IMPORT :: xt_idxlist, xt_xmap
69  IMPLICIT NONE
70  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
71  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
72  INTEGER, VALUE, INTENT(in) :: comm
73  TYPE(xt_xmap) :: res
74  END FUNCTION xmap_new
75  END INTERFACE
76  INTEGER :: comm, comm_rank, comm_size
77  INTEGER :: ierror
78  CALL init_mpi
79  comm = mpi_comm_world
80  CALL xt_initialize(comm)
81  CALL mpi_comm_rank(comm, comm_rank, ierror)
82  IF (ierror /= mpi_success) &
83  CALL test_abort("error calling mpi_comm_rank", &
84  __file__, &
85  __line__)
86  CALL mpi_comm_size(comm, comm_size, ierror)
87  IF (ierror /= mpi_success) &
88  CALL test_abort("error calling mpi_comm_size", &
89  __file__, &
90  __line__)
91  IF (comm_size > huge(1_xi)) &
92  CALL test_abort("number of ranks exceeds test limit", &
93  __file__, &
94  __line__)
95 
96  CALL test_allgather_analog(xmap_new, 1_xi, comm)
97  ! repeat test for large index list that will cause stripifying
98  CALL test_allgather_analog(xmap_new, 1024_xi, comm)
99  IF (comm_size > 2) CALL test_ring_1d(xmap_new, comm)
100  IF (comm_size == 2) CALL test_pair(xmap_new, comm)
101  IF (comm_size > 1) CALL test_ping_pong(xmap_new, comm, 0, comm_size - 1)
102 
103  IF (test_err_count() /= 0) &
104  CALL test_abort("non-zero error count!", &
105  __file__, &
106  __line__)
107  CALL xt_finalize
108  CALL finish_mpi
109  END SUBROUTINE xmap_parallel_test_main
110 
111  SUBROUTINE get_rank_range(comm, is_inter, comm_rank, comm_size)
112  INTEGER, INTENT(inout) :: comm
113  INTEGER, INTENT(out) :: comm_rank, comm_size
114  LOGICAL, INTENT(out) :: is_inter
115  INTEGER :: ierror
116 
117  CALL mpi_comm_rank(comm, comm_rank, ierror)
118  IF (ierror /= mpi_success) &
119  CALL test_abort("error calling mpi_comm_rank", &
120  __file__, &
121  __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  __file__, &
126  __line__)
127  IF (is_inter) THEN
128  CALL mpi_comm_remote_size(comm, comm_size, ierror)
129  ELSE
130  CALL mpi_comm_size(comm, comm_size, ierror)
131  END IF
132  IF (ierror /= mpi_success) &
133  CALL test_abort("error calling mpi_comm_(remote)_size", &
134  __file__, &
135  __line__)
136  END SUBROUTINE get_rank_range
137 
138  SUBROUTINE check_allgather_analog_xmap(xmap, comm)
139  TYPE(xt_xmap), INTENT(in) :: xmap
140  INTEGER, INTENT(inout) :: comm
141  INTEGER, ALLOCATABLE :: ranks(:)
142  INTEGER(xt_int_kind) :: i
143  INTEGER :: comm_rank, comm_size
144  LOGICAL :: is_inter
145 
146  CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
147  IF (xt_xmap_get_num_destinations(xmap) /= int(comm_size, xi)) &
148  CALL test_abort("error in xmap construction", &
149  __file__, &
150  __line__)
151 
152  IF (xt_xmap_get_num_sources(xmap) /= int(comm_size, xi)) &
153  CALL test_abort("error in xt_xmap_get_num_sources", &
154  __file__, &
155  __line__)
156 
157  ALLOCATE(ranks(comm_size))
158 
159  CALL xt_xmap_get_destination_ranks(xmap, ranks)
160  IF (any(ranks /= (/ (i, i=0_xi,int(comm_size-1, xi)) /))) &
161  CALL test_abort("error in xt_xmap_get_destination_ranks", &
162  __file__, &
163  __line__)
164 
165  CALL xt_xmap_get_source_ranks(xmap, ranks)
166  IF (any(ranks /= (/ (i, i=0_xi,int(comm_size-1, xi)) /))) &
167  CALL test_abort("error in xt_xmap_get_source_ranks", &
168  __file__, &
169  __line__)
170  DEALLOCATE(ranks)
171  END SUBROUTINE check_allgather_analog_xmap
172 
173  SUBROUTINE test_allgather_analog(xmap_new, num_indices_per_rank, comm)
174  INTERFACE
175  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
176  IMPORT :: xt_idxlist, xt_xmap
177  IMPLICIT NONE
178  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
179  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
180  INTEGER, VALUE, INTENT(in) :: comm
181  TYPE(xt_xmap) :: res
182  END FUNCTION xmap_new
183  END INTERFACE
184  INTEGER, INTENT(inout) :: comm
185  INTEGER(xt_int_kind), INTENT(in) :: num_indices_per_rank
186  INTEGER(xt_int_kind), ALLOCATABLE :: src_index_list(:)
187  INTEGER(xt_int_kind) :: i
188  TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
189  TYPE(xt_xmap) :: xmap, xmap_copy
190  TYPE(xt_stripe) :: dst_index_stripe(1)
191  INTEGER :: comm_size, comm_rank
192  LOGICAL :: is_inter
193 
194  CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
195  ! setup
196  ALLOCATE(src_index_list(num_indices_per_rank))
197  DO i = 1_xi, num_indices_per_rank
198  src_index_list(i) = int(comm_rank, xi) * num_indices_per_rank + i - 1_xi
199  END DO
200  src_idxlist = xt_idxvec_new(src_index_list)
201  dst_index_stripe(1) = xt_stripe(0, 1, comm_size * int(num_indices_per_rank))
202  dst_idxlist = xt_idxstripes_new(dst_index_stripe)
203  xmap = xmap_new(src_idxlist, dst_idxlist, comm)
204  CALL xt_idxlist_delete(src_idxlist)
205  CALL xt_idxlist_delete(dst_idxlist)
206 
207  ! verify expected results
208  CALL check_allgather_analog_xmap(xmap, comm)
209  xmap_copy = xt_xmap_copy(xmap)
210  CALL check_allgather_analog_xmap(xmap, comm)
211 
212  ! clean up
213  CALL xt_xmap_delete(xmap)
214  CALL xt_xmap_delete(xmap_copy)
215  END SUBROUTINE test_allgather_analog
216 
217  SUBROUTINE check_ring_xmap(xmap, dst_index_list, is_inter)
218  TYPE(xt_xmap), INTENT(in) :: xmap
219  INTEGER(xt_int_kind), INTENT(in) :: dst_index_list(2)
220  LOGICAL, INTENT(in) :: is_inter
221  INTEGER :: ranks(2), num_dst, num_src
222  num_dst = xt_xmap_get_num_destinations(xmap)
223  IF (.NOT. is_inter .AND. (num_dst > 2 .OR. num_dst < 1)) &
224  CALL test_abort("error in xt_xmap_get_num_destinations", &
225  __file__, &
226  __line__)
227 
228  num_src = xt_xmap_get_num_sources(xmap)
229  IF (num_src > 2 .OR. num_src < 1) &
230  CALL test_abort("error in xt_xmap_get_num_sources", &
231  __file__, &
232  __line__)
233 
234  IF (.NOT. is_inter) THEN
235  CALL xt_xmap_get_destination_ranks(xmap, ranks)
236  CALL xt_sort_int(ranks(1:num_dst))
237  IF (any(ranks /= dst_index_list)) &
238  CALL test_abort("error in xt_xmap_get_destination_ranks", &
239  __file__, &
240  __line__)
241  END IF
242 
243  CALL xt_xmap_get_source_ranks(xmap, ranks)
244  CALL xt_sort_int(ranks(1:num_src))
245  IF (any(ranks /= dst_index_list)) &
246  CALL test_abort("error in xt_xmap_get_source_ranks", &
247  __file__, &
248  __line__)
249  END SUBROUTINE check_ring_xmap
250 
251  SUBROUTINE test_ring_1d(xmap_new, comm)
252  INTERFACE
253  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
254  IMPORT :: xt_idxlist, xt_xmap
255  IMPLICIT NONE
256  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
257  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
258  INTEGER, VALUE, INTENT(in) :: comm
259  TYPE(xt_xmap) :: res
260  END FUNCTION xmap_new
261  END INTERFACE
262  INTEGER, INTENT(inout) :: comm
263  ! test in which each process talks WITH two other processes
264  INTEGER(xt_int_kind) :: src_index_list(1), dst_index_list(2), temp
265  TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
266  TYPE(xt_xmap) :: xmap, xmap_copy
267  INTEGER :: comm_size, comm_rank
268  LOGICAL :: is_inter
269 
270  CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
271  src_index_list(1) = int(comm_rank, xi)
272  src_idxlist = xt_idxvec_new(src_index_list)
273 
274  ! destination index list
275  dst_index_list(1) = int(mod(comm_rank + comm_size - 1, comm_size), xi)
276  dst_index_list(2) = int(mod(comm_rank + 1, comm_size), xi)
277  IF (dst_index_list(1) > dst_index_list(2)) THEN
278  temp = dst_index_list(1)
279  dst_index_list(1) = dst_index_list(2)
280  dst_index_list(2) = temp
281  END IF
282  dst_idxlist = xt_idxvec_new(dst_index_list, 2)
283 
284  ! test of exchange map
285  xmap = xmap_new(src_idxlist, dst_idxlist, comm)
286  CALL xt_idxlist_delete(src_idxlist)
287  CALL xt_idxlist_delete(dst_idxlist)
288 
289  ! test results
290  CALL check_ring_xmap(xmap, dst_index_list, is_inter)
291  xmap_copy = xt_xmap_copy(xmap)
292  CALL check_ring_xmap(xmap_copy, dst_index_list, is_inter)
293 
294  ! clean up
295  CALL xt_xmap_delete(xmap)
296  CALL xt_xmap_delete(xmap_copy)
297 
298  END SUBROUTINE test_ring_1d
299 
300  SUBROUTINE check_pair_xmap(xmap)
301  TYPE(xt_xmap), INTENT(in) :: xmap
302  INTEGER :: ranks(2)
303  ! test results
304  IF (xt_xmap_get_num_destinations(xmap) /= 2) &
305  CALL test_abort("error in xt_xmap_get_num_destinations", &
306  __file__, &
307  __line__)
308 
309  IF (xt_xmap_get_num_sources(xmap) /= 2) &
310  CALL test_abort("error in xt_xmap_get_num_sources", &
311  __file__, &
312  __line__)
313 
314  CALL xt_xmap_get_destination_ranks(xmap, ranks)
315  IF (ranks(1) /= 0 .OR. ranks(2) /= 1) &
316  CALL test_abort("error in xt_xmap_get_destination_ranks", &
317  __file__, &
318  __line__)
319 
320  CALL xt_xmap_get_source_ranks(xmap, ranks)
321  IF (ranks(1) /= 0 .OR. ranks(2) /= 1) &
322  CALL test_abort("error in xt_xmap_get_source_ranks", &
323  __file__, &
324  __line__)
325  END SUBROUTINE check_pair_xmap
326 
327  SUBROUTINE test_pair(xmap_new, comm)
328  INTERFACE
329  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
330  IMPORT :: xt_idxlist, xt_xmap
331  IMPLICIT NONE
332  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
333  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
334  INTEGER, VALUE, INTENT(in) :: comm
335  TYPE(xt_xmap) :: res
336  END FUNCTION xmap_new
337  END INTERFACE
338  INTEGER, INTENT(in) :: comm
339  !src_index_list(index, rank)
340  INTEGER(xt_int_kind) :: i, j, k
341 #ifdef __xlC__
342  INTEGER(xt_int_kind), PARAMETER :: src_index_list(20, 0:1) = reshape((/ &
343  & 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, &
344  & 9_xi, 10_xi, 11_xi, 12_xi, 13_xi, &
345  & 17_xi, 18_xi, 19_xi, 20_xi, 21_xi, &
346  & 25_xi, 26_xi, 27_xi, 28_xi, 29_xi, &
347  & 4_xi, 5_xi, 6_xi, 7_xi, 8_xi, &
348  & 12_xi, 13_xi, 14_xi, 15_xi, 16_xi, &
349  & 20_xi, 21_xi, 22_xi, 23_xi, 24_xi, &
350  & 28_xi, 29_xi, 30_xi, 31_xi, 32_xi /), &
351  (/ 20, 2 /))
352 #else
353  INTEGER(xt_int_kind), PARAMETER :: src_index_list(20, 0:1) = reshape((/ &
354  (((i + j * 8_xi + k * 3_xi, i = 1_xi, 5_xi), j = 0_xi,3_xi), &
355  k = 0_xi,1_xi) /), (/ 20, 2 /))
356 #endif
357  ! dst_index_list(index,rank)
358  INTEGER(xt_int_kind), PARAMETER :: dst_index_list(20, 0:1) = reshape((/ &
359  10_xi, 15_xi, 14_xi, 13_xi, 12_xi, &
360  15_xi, 10_xi, 11_xi, 12_xi, 13_xi, &
361  23_xi, 18_xi, 19_xi, 20_xi, 21_xi, &
362  31_xi, 26_xi, 27_xi, 28_xi, 29_xi, &
363  13_xi, 12_xi, 11_xi, 10_xi, 15_xi, &
364  12_xi, 13_xi, 14_xi, 15_xi, 10_xi, &
365  20_xi, 21_xi, 22_xi, 23_xi, 18_xi, &
366  28_xi, 29_xi, 30_xi, 31_xi, 26_xi /), &
367  (/ 20, 2 /))
368  TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
369  TYPE(xt_xmap) :: xmap, xmap_copy
370  INTEGER :: comm_rank, ierror
371 
372  CALL mpi_comm_rank(comm, comm_rank, ierror)
373  IF (ierror /= mpi_success) &
374  CALL test_abort("error calling mpi_comm_rank", &
375  __file__, &
376  __line__)
377 
378  src_idxlist = xt_idxvec_new(src_index_list(:, comm_rank))
379 
380  ! destination index list
381  dst_idxlist = xt_idxvec_new(dst_index_list(:, comm_rank))
382 
383  ! test of exchange map
384  xmap = xmap_new(src_idxlist, dst_idxlist, comm)
385  CALL xt_idxlist_delete(src_idxlist)
386  CALL xt_idxlist_delete(dst_idxlist)
387 
388  CALL check_pair_xmap(xmap)
389  xmap_copy = xt_xmap_copy(xmap)
390  CALL check_pair_xmap(xmap_copy)
391 
392  ! clean up
393  CALL xt_xmap_delete(xmap)
394  CALL xt_xmap_delete(xmap_copy)
395  END SUBROUTINE test_pair
396 
397  SUBROUTINE check_ping_pong_xmap(xmap, comm, ping_rank, pong_rank)
398  TYPE(xt_xmap), INTENT(in) :: xmap
399  INTEGER, INTENT(in) :: comm, ping_rank, pong_rank
400  INTEGER :: expect, dst_rank(1), src_rank(1), comm_rank, ierror
401  CHARACTER(len=80) :: msg
402 
403  CALL mpi_comm_rank(comm, comm_rank, ierror)
404  IF (ierror /= mpi_success) &
405  CALL test_abort('error calling mpi_comm_rank', &
406  __file__, &
407  __line__)
408  WRITE (msg, '(a,i0,a)') "error in xt_xmap_get_num_destinations (rank == ", &
409  comm_rank, ")"
410  expect = merge(1, 0, comm_rank == ping_rank)
411  IF (xt_xmap_get_num_destinations(xmap) /= expect) &
412  CALL test_abort(trim(msg), &
413  __file__, &
414  __line__)
415 
416  expect = merge(1, 0, comm_rank == pong_rank)
417  IF (xt_xmap_get_num_sources(xmap) /= expect) &
418  CALL test_abort(msg, &
419  __file__, &
420  __line__)
421 
422  IF (comm_rank == ping_rank) THEN
423  CALL xt_xmap_get_destination_ranks(xmap, dst_rank)
424  IF (dst_rank(1) /= pong_rank) &
425  CALL test_abort("error in xt_xmap_get_destination_ranks", &
426  __file__, &
427  __line__)
428  END IF
429  IF (comm_rank == pong_rank) THEN
430  CALL xt_xmap_get_source_ranks(xmap, src_rank)
431  IF (src_rank(1) /= ping_rank) &
432  CALL test_abort("error in xt_xmap_get_source_ranks", &
433  __file__, &
434  __line__)
435  END IF
436  END SUBROUTINE check_ping_pong_xmap
437 
438  SUBROUTINE test_ping_pong(xmap_new, comm, ping_rank, pong_rank)
439  INTERFACE
440  FUNCTION xmap_new(src_idxlist, dst_idxlist, comm) RESULT(res)
441  IMPORT :: xt_idxlist, xt_xmap
442  IMPLICIT NONE
443  TYPE(xt_idxlist), INTENT(in) :: src_idxlist
444  TYPE(xt_idxlist), INTENT(in) :: dst_idxlist
445  INTEGER, VALUE, INTENT(in) :: comm
446  TYPE(xt_xmap) :: res
447  END FUNCTION xmap_new
448  END INTERFACE
449  INTEGER, INTENT(in) :: ping_rank, pong_rank
450  INTEGER, INTENT(inout) :: comm
451  INTEGER(xt_int_kind), PARAMETER :: &
452  index_list(5) = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi /)
453  TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
454  TYPE(xt_xmap) :: xmap, xmap_copy
455  INTEGER :: comm_rank, comm_size
456  LOGICAL :: is_inter
457  CALL get_rank_range(comm, is_inter, comm_rank, comm_size)
458  IF (comm_rank == ping_rank) THEN
459  src_idxlist = xt_idxvec_new(index_list)
460  ELSE
461  src_idxlist = xt_idxempty_new()
462  END IF
463 
464 
465  IF (comm_rank == pong_rank) THEN
466  dst_idxlist = xt_idxvec_new(index_list)
467  ELSE
468  dst_idxlist = xt_idxempty_new()
469  END IF
470 
471  ! test of exchange map
472 
473  xmap = xmap_new(src_idxlist, dst_idxlist, comm)
474  CALL xt_idxlist_delete(src_idxlist)
475  CALL xt_idxlist_delete(dst_idxlist)
476 
477  ! test results
478  CALL check_ping_pong_xmap(xmap, comm, ping_rank, pong_rank)
479  xmap_copy = xt_xmap_copy(xmap)
480  CALL check_ping_pong_xmap(xmap_copy, comm, ping_rank, pong_rank)
481  ! clean up
482  CALL xt_xmap_delete(xmap)
483  CALL xt_xmap_delete(xmap_copy)
484  END SUBROUTINE test_ping_pong
485 END MODULE test_xmap_common_parallel
486 !
487 ! Local Variables:
488 ! f90-continuation-indent: 5
489 ! coding: utf-8
490 ! indent-tabs-mode: nil
491 ! show-trailing-whitespace: t
492 ! require-trailing-newline: t
493 ! End:
494 !
Generated by   doxygen 1.8.13