Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_redist_common_f.f90
1!>
2!! @file test_redist_common_f.f90
3!! @brief common routines for Fortran test of redist classes
4!!
5!! @copyright Copyright (C) 2013 Jörg Behrens <behrens@dkrz.de>
6!! Moritz Hanke <hanke@dkrz.de>
7!! Thomas Jahns <jahns@dkrz.de>
8!!
9!! @author Jörg Behrens <behrens@dkrz.de>
10!! Moritz Hanke <hanke@dkrz.de>
11!! Thomas Jahns <jahns@dkrz.de>
12!!
13
14!
15! Keywords:
16! Maintainer: Jörg Behrens <behrens@dkrz.de>
17! Moritz Hanke <hanke@dkrz.de>
18! Thomas Jahns <jahns@dkrz.de>
19! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
20!
21! Redistribution and use in source and binary forms, with or without
22! modification, are permitted provided that the following conditions are
23! met:
24!
25! Redistributions of source code must retain the above copyright notice,
26! this list of conditions and the following disclaimer.
27!
28! Redistributions in binary form must reproduce the above copyright
29! notice, this list of conditions and the following disclaimer in the
30! documentation and/or other materials provided with the distribution.
31!
32! Neither the name of the DKRZ GmbH nor the names of its contributors
33! may be used to endorse or promote products derived from this software
34! without specific prior written permission.
35!
36! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
37! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
38! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
39! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
40! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
41! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
42! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
43! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
44! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
45! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
46! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
47!
48#include "fc_feature_defs.inc"
49MODULE test_redist_common
50 USE xt_core, ONLY: i2, i4, i8
51 use, INTRINSIC :: iso_c_binding, only: c_ptr, c_loc
52#include "xt_slice_c_loc.inc"
53 USE mpi
54 USE yaxt, ONLY: xt_idxlist, xt_int_kind, xt_idxvec_new, xt_idxlist_delete, &
58 xt_redist_s_exchange, xt_redist_a_exchange1, xt_redist_get_mpi_comm, &
61 xi => xt_int_kind, xt_config, xt_config_new, &
63#ifdef __PGI
64 ! PGI up to at least 15.4 has a bug that prevents proper import of
65 ! multiply extended generics. This is a separate bug from the one exhibited
66 ! in 12.7 and older (see test_xmap_intersection_parallel_f.f90 for that)
67 USE xt_redist_real_dp, ONLY: xt_redist_s_exchange
68 USE xt_redist_int_i2, ONLY: xt_redist_s_exchange
69 USE xt_redist_int_i4, ONLY: xt_redist_s_exchange
70 USE xt_redist_int_i8, ONLY: xt_redist_s_exchange
71#endif
72#if defined(__GNUC__) && __GNUC__ < 4 || (__GNUC__ == 4 && __GNUC_MINOR__ <= 4)
73 ! gfortran 4.4 botches default initialization for xt_request
74 USE xt_requests, ONLY: xt_request_init
75 USE iso_c_binding, ONLY: c_null_ptr
76# define REQ_DEFAULT_INIT_FIXUP(req) CALL xt_request_init(req, c_null_ptr)
77#else
78# define REQ_DEFAULT_INIT_FIXUP(req)
79#endif
80 USE ftest_common, ONLY: test_abort, cmp_arrays
81 IMPLICIT NONE
82 PRIVATE
83 INTERFACE check_redist
84 MODULE PROCEDURE check_redist_dp
85 MODULE PROCEDURE check_redist_dp_i2
86 MODULE PROCEDURE check_redist_dp_i4
87 MODULE PROCEDURE check_redist_dp_i8
88 MODULE PROCEDURE check_redist_dp_2d
89 MODULE PROCEDURE check_redist_xi
90 MODULE PROCEDURE check_redist_i2
91 MODULE PROCEDURE check_redist_i4
92 MODULE PROCEDURE check_redist_i8
93 END INTERFACE check_redist
94
95 INTERFACE xt_redist_s_exchange
96 MODULE PROCEDURE xt_rse_int_a2d_a3d
97 END INTERFACE xt_redist_s_exchange
98
99 INTERFACE wrap_a_exchange
100 MODULE PROCEDURE wrap_a_exchange_dp
101 MODULE PROCEDURE wrap_a_exchange_dp2d
102 MODULE PROCEDURE wrap_a_exchange_i2
103 MODULE PROCEDURE wrap_a_exchange_i4
104 MODULE PROCEDURE wrap_a_exchange_i8
105 END INTERFACE wrap_a_exchange
106
107 INTERFACE test_redist_single_array_base
108 MODULE PROCEDURE test_redist_single_array_base_dp
109 END INTERFACE test_redist_single_array_base
110
111 INTERFACE check_redist_extended
112 MODULE PROCEDURE check_redist_extended_dp
113 END INTERFACE check_redist_extended
114
115 PUBLIC :: build_odd_selection_xmap, check_redist, communicators_are_congruent
116 PUBLIC :: check_wait_request, check_test_request, check_redist_xi
117 PUBLIC :: test_redist_single_array_base
118 PUBLIC :: redist_exchanger_option
119 PUBLIC :: xt_redist_s_exchange
120
121 CHARACTER(len=*), PARAMETER :: filename = 'test_redist_common_f.f90'
122
123 CHARACTER(len=29), PARAMETER :: check_redist_err_msg(2) = (/ &
124 "error in xt_redist_s_exchange", &
125 "error in xt_redist_a_exchange" /)
126
127CONTAINS
128 ! build xmap for destination list containing all odd elements of
129 ! source list dimensioned 1 to src_slice_len
130 FUNCTION build_odd_selection_xmap(src_slice_len, comm) RESULT(xmap)
131 INTEGER, INTENT(in) :: src_slice_len, comm
132 TYPE(xt_xmap) :: xmap
133 INTEGER :: i, j, dst_slice_len
134 INTEGER, PARAMETER :: dst_step = 2
135 INTEGER(xt_int_kind), ALLOCATABLE :: index_list(:)
136 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
137
138 dst_slice_len = (src_slice_len + dst_step - 1)/dst_step
139 ALLOCATE(index_list(src_slice_len))
140 DO i = 1, src_slice_len
141 index_list(i) = int(i, xt_int_kind)
142 END DO
143 src_idxlist = xt_idxvec_new(index_list)
144 j = 1
145 DO i = 1, src_slice_len, dst_step
146 index_list(j) = int(i, xt_int_kind)
147 j = j + 1
148 END DO
149 dst_idxlist = xt_idxvec_new(index_list, dst_slice_len)
150 DEALLOCATE(index_list)
151
152 xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, comm)
153 CALL xt_idxlist_delete(src_idxlist)
154 CALL xt_idxlist_delete(dst_idxlist)
155 END FUNCTION build_odd_selection_xmap
156
157 FUNCTION communicators_are_congruent(comm1, comm2) RESULT(congruent)
158 INTEGER, INTENT(in) :: comm1, comm2
159 LOGICAL :: congruent
160
161 INTEGER :: ierror, rcode
162
163 CALL mpi_comm_compare(comm1, comm2, rcode, ierror)
164 congruent = ((rcode == mpi_ident) .OR. (rcode == mpi_congruent))
165 END FUNCTION communicators_are_congruent
166
167 SUBROUTINE assert_request_is_null(request, file, line)
168 TYPE(xt_request), INTENT(in) :: request
169 INTEGER, INTENT(in) :: line
170 CHARACTER(len=*), INTENT(in) :: file
171 IF (.NOT. xt_is_null(request)) &
172 CALL test_abort("error: expected null request", &
173 file, line)
174 END SUBROUTINE assert_request_is_null
175
176 SUBROUTINE assert_request_is_not_null(request, file, line)
177 TYPE(xt_request), INTENT(in) :: request
178 INTEGER, INTENT(in) :: line
179 CHARACTER(len=*), INTENT(in) :: file
180 IF (xt_is_null(request)) &
181 CALL test_abort("error: expected non-null request", &
182 file, line)
183 END SUBROUTINE assert_request_is_not_null
184
185 SUBROUTINE check_wait_request(request, file, line)
186 TYPE(xt_request), INTENT(inout) :: request
187 CHARACTER(len=*), INTENT(in) :: file
188 INTEGER, INTENT(in) :: line
189 CALL assert_request_is_not_null(request, file, line)
190 CALL xt_request_wait(request)
191 CALL assert_request_is_null(request, file, line)
192 END SUBROUTINE check_wait_request
193
194 SUBROUTINE check_test_request(request, file, line)
195 TYPE(xt_request), INTENT(inout) :: request
196 CHARACTER(len=*), INTENT(in) :: file
197 INTEGER, INTENT(in) :: line
198 LOGICAL :: flag
199 CALL xt_request_test(request, flag)
200 IF (xt_is_null(request) .AND. .NOT. flag) &
201 CALL test_abort("error: expected flag set to .true.", file, line)
202 END SUBROUTINE check_test_request
203
204 SUBROUTINE wrap_a_exchange_dp(redist, src, dst)
205 TYPE(xt_redist), INTENT(in) :: redist
206 DOUBLE PRECISION, TARGET, INTENT(in) :: src(:)
207 DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(:)
208 DOUBLE PRECISION, TARGET :: dummy(1)
209 DOUBLE PRECISION, POINTER :: src_p(:), dst_p(:)
210
211 IF (SIZE(src) > 0) THEN
212 src_p => src
213 ELSE
214 src_p => dummy
215 END IF
216 IF (SIZE(dst) > 0) THEN
217 dst_p => dst
218 ELSE
219 dst_p => dummy
220 END IF
221 CALL wrap_a_exchange_dp_as(redist, src_p, dst_p)
222 END SUBROUTINE wrap_a_exchange_dp
223
224 SUBROUTINE wrap_a_exchange_dp_as(redist, src, dst)
225 TYPE(xt_redist), INTENT(in) :: redist
226 DOUBLE PRECISION, TARGET, INTENT(in) :: src(*)
227 DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(*)
228 TYPE(xt_request) :: request
229
230 req_default_init_fixup(request)
231 CALL assert_request_is_null(request, filename, __line__)
232 CALL xt_redist_a_exchange1(redist, c_loc(src), c_loc(dst), request)
233 CALL check_wait_request(request, filename, __line__)
234 CALL check_test_request(request, filename, __line__)
235 END SUBROUTINE wrap_a_exchange_dp_as
236
237 SUBROUTINE wrap_a_exchange_dp2d(redist, src, dst)
238 TYPE(xt_redist), INTENT(in) :: redist
239 DOUBLE PRECISION, TARGET, INTENT(in) :: src(:,:)
240 DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(:,:)
241 DOUBLE PRECISION, TARGET :: dummy(1,1)
242 DOUBLE PRECISION, POINTER :: src_p(:,:), dst_p(:,:)
243 IF (SIZE(src) > 0) THEN
244 src_p => src
245 ELSE
246 src_p => dummy
247 END IF
248 IF (SIZE(dst) > 0) THEN
249 dst_p => dst
250 ELSE
251 dst_p => dummy
252 END IF
253 CALL wrap_a_exchange_dp_as(redist, src_p, dst_p)
254 END SUBROUTINE wrap_a_exchange_dp2d
255
256 SUBROUTINE wrap_a_exchange_i2(redist, src, dst)
257 TYPE(xt_redist), INTENT(in) :: redist
258 INTEGER(i2), TARGET, INTENT(in) :: src(:)
259 INTEGER(i2), TARGET, INTENT(inout) :: dst(:)
260 INTEGER(i2), TARGET :: dummy(1)
261 INTEGER(i2), POINTER :: src_p(:), dst_p(:)
262 IF (SIZE(src) > 0) THEN
263 src_p => src
264 ELSE
265 src_p => dummy
266 END IF
267 IF (SIZE(dst) > 0) THEN
268 dst_p => dst
269 ELSE
270 dst_p => dummy
271 END IF
272 CALL wrap_a_exchange_i2_as(redist, src_p, dst_p)
273 END SUBROUTINE wrap_a_exchange_i2
274
275 SUBROUTINE wrap_a_exchange_i2_as(redist, src, dst)
276 TYPE(xt_redist), INTENT(in) :: redist
277 INTEGER(i2), TARGET, INTENT(in) :: src(*)
278 INTEGER(i2), TARGET, INTENT(inout) :: dst(*)
279 TYPE(xt_request) :: request
280
281 req_default_init_fixup(request)
282 CALL assert_request_is_null(request, filename, __line__)
283 CALL xt_redist_a_exchange1(redist, c_loc(src), c_loc(dst), request)
284 CALL check_wait_request(request, filename, __line__)
285 CALL check_test_request(request, filename, __line__)
286 END SUBROUTINE wrap_a_exchange_i2_as
287
288 SUBROUTINE wrap_a_exchange_i4(redist, src, dst)
289 TYPE(xt_redist), INTENT(in) :: redist
290 INTEGER(i4), TARGET, INTENT(in) :: src(:)
291 INTEGER(i4), TARGET, INTENT(inout) :: dst(:)
292 INTEGER(I4), TARGET :: dummy(1)
293 INTEGER(I4), POINTER :: src_p(:), dst_p(:)
294
295 IF (SIZE(src) > 0) THEN
296 src_p => src
297 ELSE
298 src_p => dummy
299 END IF
300 IF (SIZE(dst) > 0) THEN
301 dst_p => dst
302 ELSE
303 dst_p => dummy
304 END IF
305 CALL wrap_a_exchange_i4_as(redist, src_p, dst_p)
306 END SUBROUTINE wrap_a_exchange_i4
307
308 SUBROUTINE wrap_a_exchange_i4_as(redist, src, dst)
309 TYPE(xt_redist), INTENT(in) :: redist
310 INTEGER(i4), TARGET, INTENT(in) :: src(*)
311 INTEGER(i4), TARGET, INTENT(inout) :: dst(*)
312 TYPE(xt_request) :: request
313
314 req_default_init_fixup(request)
315 CALL assert_request_is_null(request, filename, __line__)
316 CALL xt_redist_a_exchange1(redist, c_loc(src), c_loc(dst), request)
317 CALL check_wait_request(request, filename, __line__)
318 CALL check_test_request(request, filename, __line__)
319 END SUBROUTINE wrap_a_exchange_i4_as
320
321 SUBROUTINE wrap_a_exchange_i8(redist, src, dst)
322 TYPE(xt_redist), INTENT(in) :: redist
323 INTEGER(i8), TARGET, INTENT(in) :: src(:)
324 INTEGER(i8), TARGET, INTENT(inout) :: dst(:)
325 INTEGER(I8), TARGET :: dummy(1)
326 INTEGER(I8), POINTER :: src_p(:), dst_p(:)
327
328 IF (SIZE(src) > 0) THEN
329 src_p => src
330 ELSE
331 src_p => dummy
332 END IF
333 IF (SIZE(dst) > 0) THEN
334 dst_p => dst
335 ELSE
336 dst_p => dummy
337 END IF
338 CALL wrap_a_exchange_i8_as(redist, src_p, dst_p)
339 END SUBROUTINE wrap_a_exchange_i8
340
341 SUBROUTINE wrap_a_exchange_i8_as(redist, src, dst)
342 TYPE(xt_redist), INTENT(in) :: redist
343 INTEGER(i8), TARGET, INTENT(in) :: src(*)
344 INTEGER(i8), TARGET, INTENT(inout) :: dst(*)
345 TYPE(xt_request) :: request
346
347 req_default_init_fixup(request)
348 CALL assert_request_is_null(request, filename, __line__)
349 CALL xt_redist_a_exchange1(redist, c_loc(src), c_loc(dst), request)
350 CALL check_wait_request(request, filename, __line__)
351 CALL check_test_request(request, filename, __line__)
352 END SUBROUTINE wrap_a_exchange_i8_as
353
354 SUBROUTINE check_redist_dp(redist, src, dst, ref_dst)
355 TYPE(xt_redist), INTENT(in) :: redist
356 DOUBLE PRECISION, INTENT(in) :: src(:), ref_dst(:)
357 DOUBLE PRECISION, INTENT(inout) :: dst(:)
358 INTEGER :: dst_size, ref_dst_size, iexch
359
360 dst_size = SIZE(dst)
361 ref_dst_size = SIZE(ref_dst)
362 IF (dst_size /= ref_dst_size) &
363 CALL test_abort("error: ref_dst larger than dst", filename, __line__)
364 DO iexch = 1, 2
365 dst = -1.0d0
366 IF (iexch == 1) THEN
367 CALL xt_redist_s_exchange(redist, src, dst)
368 ELSE
369 CALL wrap_a_exchange(redist, src, dst)
370 ENDIF
371 IF (cmp_arrays(dst, ref_dst)) &
372 CALL test_abort(check_redist_err_msg(iexch), filename, __line__)
373 ENDDO
374 END SUBROUTINE check_redist_dp
375
376 SUBROUTINE check_redist_dp_i2(redist, src, dst, ref_dst)
377 TYPE(xt_redist), INTENT(in) :: redist
378 DOUBLE PRECISION, INTENT(in) :: src(:)
379 INTEGER(i2), INTENT(in) :: ref_dst(:)
380 DOUBLE PRECISION, INTENT(inout) :: dst(:)
381 INTEGER :: dst_size, ref_dst_size, iexch
382
383 dst_size = SIZE(dst)
384 ref_dst_size = SIZE(ref_dst)
385 IF (dst_size /= ref_dst_size) &
386 CALL test_abort("error: ref_dst larger than dst", filename, __line__)
387 DO iexch = 1, 2
388 dst = -1.0d0
389 IF (iexch == 1) THEN
390 CALL xt_redist_s_exchange(redist, src, dst)
391 ELSE
392 CALL wrap_a_exchange(redist, src, dst)
393 ENDIF
394 IF (cmp_arrays(dst, dble(ref_dst))) &
395 CALL test_abort(check_redist_err_msg(iexch), filename, __line__)
396 ENDDO
397 END SUBROUTINE check_redist_dp_i2
398
399 SUBROUTINE check_redist_dp_i4(redist, src, dst, ref_dst)
400 TYPE(xt_redist), INTENT(in) :: redist
401 DOUBLE PRECISION, INTENT(in) :: src(:)
402 INTEGER(i4), INTENT(in) :: ref_dst(:)
403 DOUBLE PRECISION, INTENT(inout) :: dst(:)
404 INTEGER :: dst_size, ref_dst_size, iexch
405
406 dst_size = SIZE(dst)
407 ref_dst_size = SIZE(ref_dst)
408 IF (dst_size /= ref_dst_size) &
409 CALL test_abort("error: ref_dst larger than dst", filename, __line__)
410 DO iexch = 1, 2
411 dst = -1.0d0
412 IF (iexch == 1) THEN
413 CALL xt_redist_s_exchange(redist, src, dst)
414 ELSE
415 CALL wrap_a_exchange(redist, src, dst)
416 ENDIF
417 IF (cmp_arrays(dst, dble(ref_dst))) &
418 CALL test_abort(check_redist_err_msg(iexch), filename, __line__)
419 ENDDO
420 END SUBROUTINE check_redist_dp_i4
421
422 SUBROUTINE check_redist_dp_i8(redist, src, dst, ref_dst)
423 TYPE(xt_redist), INTENT(in) :: redist
424 DOUBLE PRECISION, INTENT(in) :: src(:)
425 INTEGER(i8), INTENT(in) :: ref_dst(:)
426 DOUBLE PRECISION, INTENT(inout) :: dst(:)
427 INTEGER :: dst_size, ref_dst_size, iexch
428
429 dst_size = SIZE(dst)
430 ref_dst_size = SIZE(ref_dst)
431 IF (dst_size /= ref_dst_size) &
432 CALL test_abort("error: ref_dst larger than dst", filename, __line__)
433 DO iexch = 1, 2
434 dst = -1.0d0
435 IF (iexch == 1) THEN
436 CALL xt_redist_s_exchange(redist, src, dst)
437 ELSE
438 CALL wrap_a_exchange(redist, src, dst)
439 ENDIF
440 IF (cmp_arrays(dst, dble(ref_dst))) &
441 CALL test_abort(check_redist_err_msg(iexch), filename, __line__)
442 ENDDO
443 END SUBROUTINE check_redist_dp_i8
444
445 SUBROUTINE check_redist_dp_2d(redist, src, dst, ref_dst)
446 TYPE(xt_redist), INTENT(in) :: redist
447 DOUBLE PRECISION, INTENT(in) :: src(:,:), ref_dst(:,:)
448 DOUBLE PRECISION, INTENT(inout) :: dst(:,:)
449 INTEGER :: dst_size, ref_dst_size, iexch
450
451 dst_size = SIZE(dst)
452 ref_dst_size = SIZE(ref_dst)
453 IF (dst_size /= ref_dst_size) &
454 CALL test_abort("error: ref_dst larger than dst", filename, __line__)
455 DO iexch = 1, 2
456 dst = -1.0d0
457 IF (iexch == 1) THEN
458 CALL xt_redist_s_exchange(redist, src, dst)
459 ELSE
460 CALL wrap_a_exchange(redist, src, dst)
461 ENDIF
462 IF (cmp_arrays(dst, ref_dst)) &
463 CALL test_abort(check_redist_err_msg(iexch), &
464 filename, __line__)
465 ENDDO
466 END SUBROUTINE check_redist_dp_2d
467
468 SUBROUTINE check_redist_xi(redist, src_size, src, dst_size, dst, ref_dst)
469 TYPE(xt_redist), INTENT(in) :: redist
470 INTEGER, INTENT(in) :: src_size, dst_size
471 INTEGER(xi), TARGET, INTENT(in) :: src(src_size)
472 INTEGER(xi), INTENT(in) :: ref_dst(dst_size)
473 INTEGER(xi), TARGET, INTENT(inout) :: dst(dst_size)
474 CALL check_redist(redist, src, dst, ref_dst)
475 END SUBROUTINE check_redist_xi
476
477 SUBROUTINE check_redist_i2(redist, src, dst, ref_dst)
478 TYPE(xt_redist), INTENT(in) :: redist
479 INTEGER(i2), INTENT(in) :: src(:), ref_dst(:)
480 INTEGER(i2), INTENT(inout) :: dst(:)
481 INTEGER :: dst_size, ref_dst_size, iexch
482
483 dst_size = SIZE(dst)
484 ref_dst_size = SIZE(ref_dst)
485 IF (dst_size /= ref_dst_size) &
486 CALL test_abort("error: ref_dst larger than dst", filename, __line__)
487 DO iexch = 1, 2
488 dst = -1_i2
489 IF (iexch == 1) THEN
490 CALL xt_redist_s_exchange(redist, src, dst)
491 ELSE
492 CALL wrap_a_exchange(redist, src, dst)
493 ENDIF
494 IF (cmp_arrays(dst, ref_dst)) &
495 CALL test_abort(check_redist_err_msg(iexch), filename, __line__)
496 ENDDO
497 END SUBROUTINE check_redist_i2
498
499 SUBROUTINE check_redist_i4(redist, src, dst, ref_dst)
500 TYPE(xt_redist), INTENT(in) :: redist
501 INTEGER(i4), INTENT(in) :: src(:), ref_dst(:)
502 INTEGER(i4), INTENT(inout) :: dst(:)
503 INTEGER :: dst_size, ref_dst_size, iexch
504
505 dst_size = SIZE(dst)
506 ref_dst_size = SIZE(ref_dst)
507 IF (dst_size /= ref_dst_size) &
508 CALL test_abort("error: ref_dst larger than dst", filename, __line__)
509 DO iexch = 1, 2
510 dst = -1_i4
511 IF (iexch == 1) THEN
512 CALL xt_redist_s_exchange(redist, src, dst)
513 ELSE
514 CALL wrap_a_exchange(redist, src, dst)
515 ENDIF
516 IF (cmp_arrays(dst, ref_dst)) &
517 CALL test_abort(check_redist_err_msg(iexch), filename, __line__)
518 ENDDO
519 END SUBROUTINE check_redist_i4
520
521 SUBROUTINE check_redist_i8(redist, src, dst, ref_dst)
522 TYPE(xt_redist), INTENT(in) :: redist
523 INTEGER(i8), INTENT(in) :: src(:), ref_dst(:)
524 INTEGER(i8), INTENT(inout) :: dst(:)
525 INTEGER :: dst_size, ref_dst_size, iexch
526
527 dst_size = SIZE(dst)
528 ref_dst_size = SIZE(ref_dst)
529 IF (dst_size /= ref_dst_size) &
530 CALL test_abort("error: ref_dst larger than dst", filename, __line__)
531 DO iexch = 1, 2
532 dst = -1_i8
533 IF (iexch == 1) THEN
534 CALL xt_redist_s_exchange(redist, src, dst)
535 ELSE
536 CALL wrap_a_exchange(redist, src, dst)
537 ENDIF
538 IF (cmp_arrays(dst, ref_dst)) &
539 CALL test_abort(check_redist_err_msg(iexch), filename, __line__)
540 ENDDO
541 END SUBROUTINE check_redist_i8
542
543 SUBROUTINE test_redist_single_array_base_dp( &
544 send_msgs, recv_msgs, src_data, ref_dst_data, comm, config)
545 TYPE(xt_redist_msg), INTENT(in) :: send_msgs(:)
546 TYPE(xt_redist_msg), INTENT(in) :: recv_msgs(:)
547 DOUBLE PRECISION, INTENT(in) :: src_data(:)
548 DOUBLE PRECISION, INTENT(in) :: ref_dst_data(:)
549 INTEGER, INTENT(in) :: comm
550 TYPE(xt_config), INTENT(in) :: config
551
552 TYPE(xt_redist) :: redist
553 INTEGER :: nsend, nrecv
554
555 redist = &
556 xt_redist_single_array_base_new(send_msgs, recv_msgs, comm, config)
557 nsend = SIZE(send_msgs)
558 IF (nsend /= xt_redist_get_num_send_msg(redist)) &
559 CALL test_abort("error in xt_redist_get_num_send_msg", &
560 filename, __line__)
561 nrecv = SIZE(recv_msgs)
562 IF (nrecv /= xt_redist_get_num_recv_msg(redist)) &
563 CALL test_abort("error in xt_redist_get_num_send_msg", &
564 filename, __line__)
565 ! test communicator of redist
566 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
567 comm)) &
568 CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
569 CALL check_redist_extended(redist, src_data, ref_dst_data)
570
571 END SUBROUTINE test_redist_single_array_base_dp
572
573 SUBROUTINE check_redist_extended_dp(redist, src_data, ref_dst_data)
574 TYPE(xt_redist), INTENT(inout) :: redist
575 DOUBLE PRECISION, INTENT(in) :: src_data(:)
576 DOUBLE PRECISION, INTENT(in) :: ref_dst_data(:)
577
578 DOUBLE PRECISION :: dst_data(SIZE(ref_dst_data))
579
580 TYPE(xt_redist) :: redist_copy
581
582 ! test exchange
583 CALL check_redist(redist, src_data, dst_data, ref_dst_data)
584 redist_copy = xt_redist_copy(redist)
585 CALL xt_redist_delete(redist)
586 CALL check_redist(redist_copy, src_data, dst_data, ref_dst_data)
587 CALL xt_redist_delete(redist_copy)
588
589 END SUBROUTINE check_redist_extended_dp
590
591 FUNCTION redist_exchanger_option() RESULT(config)
592 TYPE(xt_config) :: config
593 INTEGER :: i, num_cmd_args, arg_len
594 INTEGER :: exchanger_id
595 INTEGER, PARAMETER :: max_opt_arg_len = 80
596 CHARACTER(max_opt_arg_len) :: optarg
597 config = xt_config_new()
598 num_cmd_args = command_argument_count()
599 i = 1
600 DO WHILE (i < num_cmd_args)
601 CALL get_command_argument(i, optarg, arg_len)
602 IF (optarg(1:2) == '-m' .AND. i < num_cmd_args .AND. arg_len == 2) THEN
603 CALL get_command_argument(i + 1, optarg, arg_len)
604 IF (arg_len > max_opt_arg_len) &
605 CALL test_abort('incorrect argument to command-line option -s', &
606 filename, __line__)
607 exchanger_id = xt_exchanger_id_by_name(optarg)
608 IF (exchanger_id == -1) THEN
609 WRITE (0, *) 'arg to -m: ', optarg(1:arg_len)
610 CALL test_abort('incorrect argument to command-line option -m', &
611 filename, __line__)
612 END IF
613 CALL xt_config_set_exchange_method(config, exchanger_id)
614 i = i + 2
615 ELSE
616 WRITE (0, *) 'unexpected command-line argument parsing error: ', &
617 optarg(1:arg_len)
618 FLUSH(0)
619 CALL test_abort('unexpected command-line argument', &
620 filename, __line__)
621 END IF
622 END DO
623 END FUNCTION redist_exchanger_option
624
625 SUBROUTINE xt_rse_int_a2d_a3d(redist, src_data, target_data)
626 TYPE(xt_redist), INTENT(in) :: redist
627 INTEGER, TARGET, INTENT(in) :: src_data(:,:)
628 INTEGER, TARGET, INTENT(out) :: target_data(:,:,:)
629 TYPE(c_ptr) :: src_p, dst_p
630
631 xt_slice_c_loc(src_data, src_p)
632 xt_slice_c_loc(target_data, dst_p)
633 CALL xt_redist_s_exchange1(redist, src_p, dst_p)
634 END SUBROUTINE xt_rse_int_a2d_a3d
635
636END MODULE test_redist_common
637!
638! Local Variables:
639! f90-continuation-indent: 5
640! coding: utf-8
641! indent-tabs-mode: nil
642! show-trailing-whitespace: t
643! require-trailing-newline: t
644! End:
645!
int xt_exchanger_id_by_name(const char *name)
Definition xt_config.c:126
void xt_config_set_exchange_method(Xt_config config, int method)
Definition xt_config.c:297
Xt_config xt_config_new(void)
Definition xt_config.c:78
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
Definition xt_idxvec.c:213
void xt_redist_delete(Xt_redist redist)
Definition xt_redist.c:74
int xt_redist_get_num_recv_msg(Xt_redist redist)
Definition xt_redist.c:108
int xt_redist_get_num_send_msg(Xt_redist redist)
Definition xt_redist.c:103
void xt_redist_a_exchange1(Xt_redist redist, const void *src_data, void *dst_data, Xt_request *request)
Definition xt_redist.c:97
Xt_redist xt_redist_copy(Xt_redist redist)
Definition xt_redist.c:69
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[])
Definition xt_redist.c:79
void xt_redist_s_exchange1(Xt_redist redist, const void *src_data, void *dst_data)
Definition xt_redist.c:92
Xt_redist xt_redist_single_array_base_new(int nsend, int nrecv, const struct Xt_redist_msg send_msgs[], const struct Xt_redist_msg recv_msgs[], MPI_Comm comm)
void xt_request_wait(Xt_request *request)
Definition xt_request.c:57
void xt_request_test(Xt_request *request, int *flag)
Definition xt_request.c:66
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)