Yet Another eXchange Tool  0.9.0
test_xmap_intersection_parallel_f.f90
1 
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 PROGRAM test_xmap_intersection_parallel
46  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort, posix_exit
47  USE mpi
48  USE iso_c_binding, ONLY: c_int
49  USE test_idxlist_utils, ONLY: test_err_count
50  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_int_kind, &
51  xt_idxlist, xt_idxvec_new, xt_idxlist_delete, xt_xmap, &
52  xt_idxempty_new, xi => xt_int_kind, &
54  xt_xmap_intersection_pos_new, xt_com_pos, &
55  xt_xmap_copy, xt_xmap_delete, xt_xmap_iter, &
60  xt_xmap_iterator_delete, xt_xmap_reorder, xt_reorder_type_kind, &
61  xt_reorder_none, xt_reorder_send_up, xt_reorder_recv_up, &
62  xt_sort_permutation, xt_xmap_update_positions, xt_xmap_spread
63 #if defined __PGI && ( __PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 7))
64  ! PGI Fortran 12.7 and older has a bug that prevents proper passing of
65  ! generic interfaces through multiple modules, direct USE instead
66  USE xt_xmap_abstract, ONLY: xt_is_null
67 #else
68  USE yaxt, ONLY: xt_is_null
69 #endif
70  IMPLICIT NONE
71 
72  TYPE test_message
73  INTEGER :: rank ! rank of communication partner
74  INTEGER, POINTER :: pos(:) ! positions to be sent/received
75  END TYPE test_message
76 
77  INTEGER, PARAMETER :: xmi_type_base = 0, xmi_type_ext = 1
78  INTEGER :: xmi_type
79 
80  INTEGER :: ierror
81  INTEGER :: my_rank, comm_size
82  CHARACTER(len=*), PARAMETER :: &
83  filename = 'test_xmap_intersection_parallel_f.f90'
84 
85  CALL init_mpi
86  CALL xt_initialize(mpi_comm_world)
87  xmi_type = xmi_type_base
88  CALL parse_options
89 
90  CALL mpi_comm_rank(mpi_comm_world, my_rank, ierror)
91  IF (ierror /= mpi_success) &
92  CALL test_abort("MPI error!", filename, __line__)
93 
94  CALL mpi_comm_size(mpi_comm_world, comm_size, ierror)
95  IF (ierror /= mpi_success) &
96  CALL test_abort("MPI error!", filename, __line__)
97 
98  IF (comm_size /= 3) THEN
99  CALL xt_finalize
100  CALL finish_mpi
101  CALL posix_exit(77_c_int)
102  END IF
103 
104  ! parse_options(&argc, &argv);
105  CALL simple_rr_test
106  CALL elimination_test
107  CALL one_to_one_comm_test
108  CALL full_comm_matrix_test
109  CALL dedup_test
110  CALL reorder_test
111  CALL update_positions_and_spread_test
112  CALL alltoall_pos_test
113 
114  IF (test_err_count() /= 0) &
115  CALL test_abort("non-zero error count!", filename, __line__)
116  CALL xt_finalize
117  CALL finish_mpi
118 
119 CONTAINS
120  ! simple test (round robin)
121  SUBROUTINE simple_rr_test
122  ! setup
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)
133 
134  src_index(1) = int(my_rank, xi)
135  dst_index(1) = int(mod(my_rank + 1, comm_size), xi)
136  src_idxlist = xt_idxvec_new(src_index)
137  dst_idxlist = xt_idxvec_new(dst_index)
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))
140 
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)
144 
145  ! test
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
150 
151  CALL test_xmap(xmap, send_messages, recv_messages)
152 
153  ! cleanup
154  CALL xt_xmap_delete(xmap)
155  CALL xt_idxlist_delete(dst_idxlist)
156  CALL xt_idxlist_delete(src_idxlist)
157  END SUBROUTINE simple_rr_test
158 
159  ! rank 0 receives the same point from rank 1 and 2
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, &
165  num_recvs
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)
170  ! setup
171  IF (my_rank == 0) THEN
172  src_idxlist = xt_idxempty_new()
173  dst_idxlist = xt_idxvec_new(dst_index)
174  ELSE
175  src_idxlist = xt_idxvec_new(src_index)
176  dst_idxlist = xt_idxempty_new()
177  END IF
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)
183 
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)
187 
188  ! test
189  send_pos(1) = 0
190  num_sends = merge(1, 0, my_rank == 1)
191  send_messages(1)%rank = 0
192  send_messages(1)%pos => send_pos
193  recv_pos(1) = 0;
194  num_recvs = merge(1, 0, my_rank == 0)
195  recv_messages(1)%rank = 1
196  recv_messages(1)%pos => recv_pos
197 
198  CALL test_xmap(xmap, send_messages(1:num_sends), recv_messages(1:num_recvs))
199 
200  ! cleanup
201 
202  CALL xt_xmap_delete(xmap)
203  CALL xt_idxlist_delete(dst_idxlist)
204  CALL xt_idxlist_delete(src_idxlist)
205  END SUBROUTINE elimination_test
206 
207  ! all ranks can receive data from one of the others
208  SUBROUTINE one_to_one_comm_test
209  ! rank | 0 | 1 | 2 |
210  ! source indices | 1,2 | 2,0 | 0,1 |
211  ! destination indice | 0 | 1 | 2 |
212 
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)
221  ! setup
222  dst_index(1) = int(my_rank, xi)
223  DO i = 1, 2
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)
226  END DO
227  src_idxlist = xt_idxvec_new(src_indices, 2)
228  dst_idxlist = xt_idxvec_new(dst_index, 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, &
236  mpi_comm_world)
237 
238  ! test
239  recv_pos(1) = 0
240  num_recvs = 1
241  SELECT CASE (my_rank)
242  CASE (0)
243  send_pos(1) = 0
244  send_pos(2) = 1
245  num_sends = 2
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
251  CASE (1)
252  send_pos = 1
253  num_sends = 1
254  send_messages(1)%rank = 0
255  send_messages(1)%pos => send_pos(1:1)
256  recv_messages(1)%rank = 0
257  CASE default
258  num_sends = 0
259  recv_messages(1)%rank = 0
260  END SELECT
261  recv_messages(1)%pos => recv_pos(1:1)
262  CALL test_xmap(xmap, send_messages(1:num_sends), recv_messages(1:num_recvs))
263 
264  ! cleanup
265  CALL xt_xmap_delete(xmap)
266  CALL xt_idxlist_delete(src_intersection_idxlist(2))
267  CALL xt_idxlist_delete(src_intersection_idxlist(1))
268  CALL xt_idxlist_delete(dst_idxlist)
269  CALL xt_idxlist_delete(src_idxlist)
270  END SUBROUTINE one_to_one_comm_test
271 
272  ! all ranks receive data from each of the others
273  SUBROUTINE full_comm_matrix_test
274  !rank | 0 | 1 | 2
275  !source indices | 0,1,2,3,4 | 3,4,5,6,7 | 6,7,8,0,1
276  !destination indices|0,1,2,3,4,5,6,7,8|0,1,2,3,4,5,6,7,8|0,1,2,3,4,5,6,7,8
277 
278 
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 /)), &
283  dst_indices(9) &
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 /), &
291  recv_pos(5, 0:2) &
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)
295  INTEGER :: i
296 
297  ! setup
298  src_idxlist = xt_idxvec_new(src_indices(:, my_rank))
299  dst_idxlist = xt_idxvec_new(dst_indices, 9)
300  DO i = 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)
303  END DO
304  xmap = xmi_new(src_com, dst_com, src_idxlist, dst_idxlist, &
305  mpi_comm_world)
306 
307  ! test
308  DO i = 0, 2
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)
313  END DO
314  CALL test_xmap(xmap, send_messages, recv_messages)
315 
316  ! cleanup
317  CALL xt_xmap_delete(xmap)
318  DO i = 2, 0, -1
319  CALL xt_idxlist_delete(dst_com(i)%list)
320  END DO
321  CALL xt_idxlist_delete(dst_idxlist)
322  CALL xt_idxlist_delete(src_idxlist)
323  END SUBROUTINE full_comm_matrix_test
324 
325  ! one rank receives data from the other two, that have duplicated indices
326  ! (this provokes a bug found by Joerg Behrens)
327  SUBROUTINE dedup_test
328  ! rank | 0 | 1 | 2 |
329  ! source indices | 0,2 | 1,2 | |
330  ! destination indices | | | 0,1,2 |
331 
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)
346  ! setup
347  IF (my_rank == 2) THEN
348  num_src_intersections = 0
349  num_dst_intersections = 2
350  DO i = 0, 1
351  dst_com(i+1)%list = xt_idxvec_new(src_indices(:, i))
352  dst_com(i+1)%rank = i
353  END DO
354  src_idxlist = xt_idxempty_new()
355  dst_idxlist = xt_idxvec_new(dst_indices(:))
356  ELSE
357  num_src_intersections = 1
358  src_com(1)%list = xt_idxvec_new(src_indices(:, my_rank))
359  src_com(1)%rank = 2
360  num_dst_intersections = 0;
361  src_idxlist = xt_idxvec_new(src_indices(:, my_rank))
362  dst_idxlist = xt_idxempty_new()
363  END IF
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)
367 
368  ! test
369  IF (my_rank == 2) THEN
370  num_recv_messages = 2
371  num_send_messages = 0
372  DO i = 1, 2
373  recv_messages(i)%rank = i - 1
374  recv_messages(i)%pos => recv_pos(1:num_recv_pos(i), i)
375  END DO
376  ELSE
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)
381  END IF
382  CALL test_xmap(xmap, send_messages(1:num_send_messages), &
383  recv_messages(1:num_recv_messages))
384 
385  ! cleanup
386  CALL xt_xmap_delete(xmap)
387  CALL xt_idxlist_delete(dst_idxlist)
388  CALL xt_idxlist_delete(src_idxlist)
389  CALL xt_idxlist_delete(dst_com(1:num_dst_intersections)%list)
390  CALL xt_idxlist_delete(src_com(1:num_src_intersections)%list)
391  END SUBROUTINE dedup_test
392 
393  ! checks the reorder functionality of exchange maps
394  SUBROUTINE reorder_test
395 
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/)
407  INTEGER :: i
408  INTEGER, SAVE, TARGET :: send_pos(6), recv_pos(6)
409  TYPE(test_message) :: recv_messages(1), send_messages(1)
410 
411  ! setup
412  src_idxlist = xt_idxvec_new(src_indices(:))
413  dst_idxlist = xt_idxvec_new(dst_indices(:))
414  src_com(1)%list = xt_idxvec_new(intersection_indices)
415  src_com(1)%rank = mod(my_rank + 1, comm_size)
416  dst_com(1)%list = xt_idxvec_new(intersection_indices)
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)
419 
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
424 
425  ! test
426  DO i = 1, 3
427  xmap_reorder = xt_xmap_reorder(xmap, reorder_types(i))
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)
435  END SELECT
436  CALL test_xmap(xmap_reorder, send_messages, recv_messages)
437  CALL xt_xmap_delete(xmap_reorder)
438  END DO
439 
440  ! cleanup
441  CALL xt_xmap_delete(xmap)
442  CALL xt_idxlist_delete(dst_idxlist)
443  CALL xt_idxlist_delete(src_idxlist)
444  CALL xt_idxlist_delete(dst_com(1)%list)
445  CALL xt_idxlist_delete(src_com(1)%list)
446  END SUBROUTINE reorder_test
447 
448  ! checks the update positions functionality of exchange maps
449  SUBROUTINE update_positions_and_spread_test
450 
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)
461 
462  ! setup
463  src_idxlist = xt_idxvec_new(indices)
464  dst_idxlist = xt_idxvec_new(indices)
465  src_com(1)%list = xt_idxvec_new(indices)
466  src_com(1)%rank = mod(my_rank + 1, comm_size)
467  dst_com(1)%list = xt_idxvec_new(indices)
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)
470 
471  i = 1
472  DO lev = 0, nlev - 1
473  DO blk = 0, nblk - 1
474  DO idx = 0, nproma - 1
475  blocked_positions(i) = idx + (blk * nlev + lev) * nproma
476  i = i + 1
477  END DO
478  END DO
479  END DO
480  DO i = 1, nlev
481  displacements(i) = (i - 1) * nproma
482  END DO
483 
484  xmap_single_level_blocked = &
485  xt_xmap_update_positions(xmap, blocked_positions, blocked_positions);
486  xmap_multi_level_blocked = &
487  xt_xmap_spread( &
488  xmap_single_level_blocked, nlev, displacements, displacements);
489 
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
494 
495  ! test
496  CALL test_xmap(xmap_multi_level_blocked, send_messages, recv_messages)
497 
498  ! cleanup
499  CALL xt_xmap_delete(xmap_multi_level_blocked)
500  CALL xt_xmap_delete(xmap_single_level_blocked)
501  CALL xt_xmap_delete(xmap)
502  CALL xt_idxlist_delete(dst_idxlist)
503  CALL xt_idxlist_delete(src_idxlist)
504  CALL xt_idxlist_delete(dst_com(1)%list)
505  CALL xt_idxlist_delete(src_com(1)%list)
506  END SUBROUTINE update_positions_and_spread_test
507 
508  ! checks xt_xmap_intersection_pos_new constructor
509  SUBROUTINE alltoall_pos_test
510 
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)
515  INTEGER :: i
516 
517  DO i = 1, comm_size
518  transfer_pos(i) = i
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)
527  END DO
528 
529  xmap = xt_xmap_intersection_pos_new(src_com, dst_com, mpi_comm_world)
530 
531  ! test
532  CALL test_xmap(xmap, send_messages, recv_messages)
533 
534  ! cleanup
535  CALL xt_xmap_delete(xmap)
536  END SUBROUTINE alltoall_pos_test
537 
538  SUBROUTINE test_xmap_iter(iter, msgs)
539  TYPE(xt_xmap_iter), INTENT(inout) :: iter
540  TYPE(test_message), INTENT(in) :: msgs(:)
541 
542  INTEGER :: num_msgs, num_pos, i, j
543  INTEGER, POINTER :: pos(:)
544  LOGICAL :: iter_is_null
545 
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)', &
552  filename, __line__)
553  ELSE IF (iter_is_null) THEN
554  CALL test_abort('ERROR: xt_xmap_get_*_iterator &
555  &(iter should not be NULL)', &
556  filename, __line__)
557  ELSE
558  i = 1
559  DO WHILE(.true.)
560  IF (xt_xmap_iterator_get_rank(iter) /= msgs(i)%rank) &
561  CALL test_abort('ERROR: xt_xmap_iterator_get_rank', &
562  filename, __line__)
563  num_pos = SIZE(msgs(i)%pos)
564  IF (xt_xmap_iterator_get_num_transfer_pos(iter) /= num_pos) THEN
565  CALL test_abort("ERROR: xt_xmap_iterator_get_num_transfer_pos", &
566  filename, __line__)
567  END IF
569  DO j = 1, num_pos
570  IF (pos(j) /= msgs(i)%pos(j)) &
571  CALL test_abort('ERROR: xt_xmap_iterator_get_transfer_pos', &
572  filename, __line__)
573  END DO
574  IF (.NOT. xt_xmap_iterator_next(iter)) EXIT
575  i = i + 1
576  END DO
577  IF (i /= num_msgs) &
578  CALL test_abort('ERROR: xt_xmap_iterator_next &
579  &(wrong number of messages)', &
580  filename, __line__)
581  END IF
582  END SUBROUTINE test_xmap_iter
583 
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(:)
587 
588  INTEGER :: num_sends, num_recvs
589  TYPE(xt_xmap_iter) :: send_iter, recv_iter
590  INTEGER, PARAMETER :: num_xmaps_2_test = 2
591  INTEGER :: i
592  TYPE(xt_xmap) :: maps(num_xmaps_2_test)
593 
594  maps(1) = xmap
595  maps(2) = xt_xmap_copy(xmap)
596  DO i = 1, num_xmaps_2_test
597  num_sends = SIZE(send_messages)
598  num_recvs = SIZE(recv_messages)
599  IF (xt_xmap_get_num_destinations(maps(i)) /= num_sends) &
600  CALL test_abort('ERROR: xt_xmap_get_num_destinations', filename, &
601  __line__)
602  IF (xt_xmap_get_num_sources(maps(i)) /= num_recvs) &
603  CALL test_abort('ERROR: xt_xmap_get_num_sources', filename, __line__)
604  send_iter = xt_xmap_get_out_iterator(maps(i))
605  recv_iter = xt_xmap_get_in_iterator(maps(i))
606 
607  CALL test_xmap_iter(send_iter, send_messages)
608  CALL test_xmap_iter(recv_iter, recv_messages)
609 
610  IF (.NOT. xt_is_null(recv_iter)) CALL xt_xmap_iterator_delete(recv_iter)
611  IF (.NOT. xt_is_null(send_iter)) CALL xt_xmap_iterator_delete(send_iter)
612  END DO
613  CALL xt_xmap_delete(maps(2))
614  END SUBROUTINE test_xmap
615 
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()
621  i = 1
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', &
628  filename, __line__)
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
633  ELSE
634  WRITE (0, *) 'arg to -m: ', optarg(1:arg_len)
635  CALL test_abort('incorrect argument to command-line option -m', &
636  filename, __line__)
637  END IF
638  i = i + 2
639  ELSE
640  WRITE (0, *) 'unexpected command-line argument parsing error: ', &
641  trim(optarg)
642  FLUSH(0)
643  CALL test_abort('unexpected command-line argument -m', filename, &
644  __line__)
645  END IF
646  END DO
647  END SUBROUTINE parse_options
648 
649  FUNCTION xmi_new(src_com, dst_com, src_idxlist, dst_idxlist, comm) &
650  result(xmap)
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)
656  CASE(xmi_type_base)
657  xmap = xt_xmap_intersection_new(src_com, dst_com, &
658  src_idxlist, dst_idxlist, comm)
659  CASE(xmi_type_ext)
660  xmap = xt_xmap_intersection_ext_new(src_com, dst_com, &
661  src_idxlist, dst_idxlist, comm)
662  END SELECT
663  END FUNCTION xmi_new
664 
665 END PROGRAM test_xmap_intersection_parallel
666 !
667 ! Local Variables:
668 ! f90-continuation-indent: 5
669 ! coding: utf-8
670 ! indent-tabs-mode: nil
671 ! show-trailing-whitespace: t
672 ! require-trailing-newline: t
673 ! End:
674 !
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_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
int xt_xmap_iterator_next(Xt_xmap_iter iter)
Definition: xt_xmap.c:100
Xt_xmap xt_xmap_reorder(Xt_xmap xmap, enum xt_reorder_type type)
Definition: xt_xmap.c:142
void xt_xmap_delete(Xt_xmap xmap)
Definition: xt_xmap.c:85
Xt_xmap_iter xt_xmap_get_out_iterator(Xt_xmap xmap)
Definition: xt_xmap.c:95
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 const * xt_xmap_iterator_get_transfer_pos(Xt_xmap_iter iter)
Definition: xt_xmap.c:110
void xt_xmap_iterator_delete(Xt_xmap_iter iter)
Definition: xt_xmap.c:129
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_iterator_get_rank(Xt_xmap_iter iter)
Definition: xt_xmap.c:105
int xt_xmap_get_num_sources(Xt_xmap xmap)
Definition: xt_xmap.c:65
Xt_xmap_iter xt_xmap_get_in_iterator(Xt_xmap xmap)
Definition: xt_xmap.c:90
int xt_xmap_iterator_get_num_transfer_pos(Xt_xmap_iter iter)
Definition: xt_xmap.c:115
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)