48 MODULE test_redist_common
50 USE iso_c_binding,
ONLY: c_loc, c_int, c_char, c_null_char
70 #if defined(__GNUC__) && __GNUC__ < 4 || (__GNUC__ == 4 && __GNUC_MINOR__ <= 4)
73 USE iso_c_binding,
ONLY: c_null_ptr
74 # define REQ_DEFAULT_INIT_FIXUP(req) CALL xt_request_init(req, c_null_ptr)
76 # define REQ_DEFAULT_INIT_FIXUP(req)
78 USE ftest_common,
ONLY: test_abort, cmp_arrays
81 INTERFACE check_redist
82 MODULE PROCEDURE check_redist_dp
83 MODULE PROCEDURE check_redist_dp_i2
84 MODULE PROCEDURE check_redist_dp_i4
85 MODULE PROCEDURE check_redist_dp_i8
86 MODULE PROCEDURE check_redist_dp_2d
87 MODULE PROCEDURE check_redist_xi
88 MODULE PROCEDURE check_redist_i2
89 MODULE PROCEDURE check_redist_i4
90 MODULE PROCEDURE check_redist_i8
91 END INTERFACE check_redist
93 INTERFACE wrap_a_exchange
94 MODULE PROCEDURE wrap_a_exchange_dp
95 MODULE PROCEDURE wrap_a_exchange_dp2d
96 MODULE PROCEDURE wrap_a_exchange_i2
97 MODULE PROCEDURE wrap_a_exchange_i4
98 MODULE PROCEDURE wrap_a_exchange_i8
99 END INTERFACE wrap_a_exchange
101 INTERFACE test_redist_single_array_base
102 MODULE PROCEDURE test_redist_single_array_base_dp
103 END INTERFACE test_redist_single_array_base
105 INTERFACE check_redist_extended
106 MODULE PROCEDURE check_redist_extended_dp
107 END INTERFACE check_redist_extended
109 PUBLIC :: build_odd_selection_xmap, check_redist, communicators_are_congruent
110 PUBLIC :: check_wait_request, check_test_request, check_redist_xi
111 PUBLIC :: test_redist_single_array_base
112 PUBLIC :: redist_exchanger_option
114 CHARACTER(len=*),
PARAMETER :: filename =
'test_redist_common_f.f90'
119 FUNCTION build_odd_selection_xmap(src_slice_len)
RESULT(xmap)
120 INTEGER,
INTENT(in) :: src_slice_len
121 TYPE(xt_xmap) :: xmap
122 INTEGER :: i, j, dst_slice_len
123 INTEGER,
PARAMETER :: dst_step = 2
124 INTEGER(xt_int_kind),
ALLOCATABLE :: index_list(:)
125 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
127 dst_slice_len = (src_slice_len + dst_step - 1)/dst_step
128 ALLOCATE(index_list(src_slice_len))
129 DO i = 1, src_slice_len
130 index_list(i) = int(i, xt_int_kind)
134 DO i = 1, src_slice_len, dst_step
135 index_list(j) = int(i, xt_int_kind)
139 DEALLOCATE(index_list)
144 END FUNCTION build_odd_selection_xmap
146 FUNCTION communicators_are_congruent(comm1, comm2)
RESULT(congruent)
147 INTEGER,
INTENT(in) :: comm1, comm2
150 INTEGER :: ierror, rcode
152 CALL mpi_comm_compare(comm1, comm2, rcode, ierror)
153 congruent = ((rcode == mpi_ident) .OR. (rcode == mpi_congruent))
154 END FUNCTION communicators_are_congruent
156 SUBROUTINE assert_request_is_null(request, file, line)
157 TYPE(xt_request),
INTENT(in) :: request
158 INTEGER,
INTENT(in) :: line
159 CHARACTER(len=*),
INTENT(in) :: file
160 IF (.NOT. xt_is_null(request)) &
161 CALL test_abort(
"error: expected null request", &
163 END SUBROUTINE assert_request_is_null
165 SUBROUTINE assert_request_is_not_null(request, file, line)
166 TYPE(xt_request),
INTENT(in) :: request
167 INTEGER,
INTENT(in) :: line
168 CHARACTER(len=*),
INTENT(in) :: file
169 IF (xt_is_null(request)) &
170 CALL test_abort(
"error: expected non-null request", &
172 END SUBROUTINE assert_request_is_not_null
174 SUBROUTINE check_wait_request(request, file, line)
175 TYPE(xt_request),
INTENT(inout) :: request
176 CHARACTER(len=*),
INTENT(in) :: file
177 INTEGER,
INTENT(in) :: line
178 CALL assert_request_is_not_null(request, file, line)
180 CALL assert_request_is_null(request, file, line)
181 END SUBROUTINE check_wait_request
183 SUBROUTINE check_test_request(request, file, line)
184 TYPE(xt_request),
INTENT(inout) :: request
185 CHARACTER(len=*),
INTENT(in) :: file
186 INTEGER,
INTENT(in) :: line
189 IF (xt_is_null(request) .AND. .NOT. flag) &
190 CALL test_abort(
"error: expected flag set to .true.", file, line)
191 END SUBROUTINE check_test_request
193 SUBROUTINE wrap_a_exchange_dp(redist, src, dst)
194 TYPE(xt_redist),
INTENT(in) :: redist
195 DOUBLE PRECISION,
TARGET,
INTENT(in) :: src(:)
196 DOUBLE PRECISION,
TARGET,
INTENT(inout) :: dst(:)
197 DOUBLE PRECISION,
TARGET :: dummy(1)
198 DOUBLE PRECISION,
POINTER :: src_p(:), dst_p(:)
200 IF (
SIZE(src) > 0)
THEN
205 IF (
SIZE(dst) > 0)
THEN
210 CALL wrap_a_exchange_dp_as(redist, src_p, dst_p)
211 END SUBROUTINE wrap_a_exchange_dp
213 SUBROUTINE wrap_a_exchange_dp_as(redist, src, dst)
214 TYPE(xt_redist),
INTENT(in) :: redist
215 DOUBLE PRECISION,
TARGET,
INTENT(in) :: src(*)
216 DOUBLE PRECISION,
TARGET,
INTENT(inout) :: dst(*)
217 TYPE(xt_request) :: request
219 req_default_init_fixup(request)
220 CALL assert_request_is_null(request, filename, __line__)
222 CALL check_wait_request(request, filename, __line__)
223 CALL check_test_request(request, filename, __line__)
224 END SUBROUTINE wrap_a_exchange_dp_as
226 SUBROUTINE wrap_a_exchange_dp2d(redist, src, dst)
227 TYPE(xt_redist),
INTENT(in) :: redist
228 DOUBLE PRECISION,
TARGET,
INTENT(in) :: src(:,:)
229 DOUBLE PRECISION,
TARGET,
INTENT(inout) :: dst(:,:)
230 DOUBLE PRECISION,
TARGET :: dummy(1,1)
231 DOUBLE PRECISION,
POINTER :: src_p(:,:), dst_p(:,:)
232 IF (
SIZE(src) > 0)
THEN
237 IF (
SIZE(dst) > 0)
THEN
242 CALL wrap_a_exchange_dp_as(redist, src_p, dst_p)
243 END SUBROUTINE wrap_a_exchange_dp2d
245 SUBROUTINE wrap_a_exchange_i2(redist, src, dst)
246 TYPE(xt_redist),
INTENT(in) :: redist
247 INTEGER(i2),
TARGET,
INTENT(in) :: src(:)
248 INTEGER(i2),
TARGET,
INTENT(inout) :: dst(:)
249 INTEGER(i2),
TARGET :: dummy(1)
250 INTEGER(i2),
POINTER :: src_p(:), dst_p(:)
251 IF (
SIZE(src) > 0)
THEN
256 IF (
SIZE(dst) > 0)
THEN
261 CALL wrap_a_exchange_i2_as(redist, src_p, dst_p)
262 END SUBROUTINE wrap_a_exchange_i2
264 SUBROUTINE wrap_a_exchange_i2_as(redist, src, dst)
265 TYPE(xt_redist),
INTENT(in) :: redist
266 INTEGER(i2),
TARGET,
INTENT(in) :: src(*)
267 INTEGER(i2),
TARGET,
INTENT(inout) :: dst(*)
268 TYPE(xt_request) :: request
270 req_default_init_fixup(request)
271 CALL assert_request_is_null(request, filename, __line__)
273 CALL check_wait_request(request, filename, __line__)
274 CALL check_test_request(request, filename, __line__)
275 END SUBROUTINE wrap_a_exchange_i2_as
277 SUBROUTINE wrap_a_exchange_i4(redist, src, dst)
278 TYPE(xt_redist),
INTENT(in) :: redist
279 INTEGER(i4),
TARGET,
INTENT(in) :: src(:)
280 INTEGER(i4),
TARGET,
INTENT(inout) :: dst(:)
281 INTEGER(I4),
TARGET :: dummy(1)
282 INTEGER(I4),
POINTER :: src_p(:), dst_p(:)
284 IF (
SIZE(src) > 0)
THEN
289 IF (
SIZE(dst) > 0)
THEN
294 CALL wrap_a_exchange_i4_as(redist, src_p, dst_p)
295 END SUBROUTINE wrap_a_exchange_i4
297 SUBROUTINE wrap_a_exchange_i4_as(redist, src, dst)
298 TYPE(xt_redist),
INTENT(in) :: redist
299 INTEGER(i4),
TARGET,
INTENT(in) :: src(*)
300 INTEGER(i4),
TARGET,
INTENT(inout) :: dst(*)
301 TYPE(xt_request) :: request
303 req_default_init_fixup(request)
304 CALL assert_request_is_null(request, filename, __line__)
306 CALL check_wait_request(request, filename, __line__)
307 CALL check_test_request(request, filename, __line__)
308 END SUBROUTINE wrap_a_exchange_i4_as
310 SUBROUTINE wrap_a_exchange_i8(redist, src, dst)
311 TYPE(xt_redist),
INTENT(in) :: redist
312 INTEGER(i8),
TARGET,
INTENT(in) :: src(:)
313 INTEGER(i8),
TARGET,
INTENT(inout) :: dst(:)
314 INTEGER(I8),
TARGET :: dummy(1)
315 INTEGER(I8),
POINTER :: src_p(:), dst_p(:)
317 IF (
SIZE(src) > 0)
THEN
322 IF (
SIZE(dst) > 0)
THEN
327 CALL wrap_a_exchange_i8_as(redist, src_p, dst_p)
328 END SUBROUTINE wrap_a_exchange_i8
330 SUBROUTINE wrap_a_exchange_i8_as(redist, src, dst)
331 TYPE(xt_redist),
INTENT(in) :: redist
332 INTEGER(i8),
TARGET,
INTENT(in) :: src(*)
333 INTEGER(i8),
TARGET,
INTENT(inout) :: dst(*)
334 TYPE(xt_request) :: request
336 req_default_init_fixup(request)
337 CALL assert_request_is_null(request, filename, __line__)
339 CALL check_wait_request(request, filename, __line__)
340 CALL check_test_request(request, filename, __line__)
341 END SUBROUTINE wrap_a_exchange_i8_as
343 SUBROUTINE check_redist_dp(redist, src, dst, ref_dst)
344 TYPE(xt_redist),
INTENT(in) :: redist
345 DOUBLE PRECISION,
INTENT(in) :: src(:), ref_dst(:)
346 DOUBLE PRECISION,
INTENT(inout) :: dst(:)
347 INTEGER :: dst_size, ref_dst_size, iexch
350 ref_dst_size =
SIZE(ref_dst)
351 IF (dst_size /= ref_dst_size) &
352 CALL test_abort(
"error: ref_dst larger than dst", filename, __line__)
358 CALL wrap_a_exchange(redist, src, dst)
360 IF (cmp_arrays(dst, ref_dst)) &
361 CALL test_abort(
"error in xt_redist_s_exchange1", filename, __line__)
363 END SUBROUTINE check_redist_dp
365 SUBROUTINE check_redist_dp_i2(redist, src, dst, ref_dst)
366 TYPE(xt_redist),
INTENT(in) :: redist
367 DOUBLE PRECISION,
INTENT(in) :: src(:)
368 INTEGER(i2),
INTENT(in) :: ref_dst(:)
369 DOUBLE PRECISION,
INTENT(inout) :: dst(:)
370 INTEGER :: dst_size, ref_dst_size, iexch
373 ref_dst_size =
SIZE(ref_dst)
374 IF (dst_size /= ref_dst_size) &
375 CALL test_abort(
"error: ref_dst larger than dst", filename, __line__)
381 CALL wrap_a_exchange(redist, src, dst)
383 IF (cmp_arrays(dst, dble(ref_dst))) &
384 CALL test_abort(
"error in xt_redist_s_exchange1", filename, __line__)
386 END SUBROUTINE check_redist_dp_i2
388 SUBROUTINE check_redist_dp_i4(redist, src, dst, ref_dst)
389 TYPE(xt_redist),
INTENT(in) :: redist
390 DOUBLE PRECISION,
INTENT(in) :: src(:)
391 INTEGER(i4),
INTENT(in) :: ref_dst(:)
392 DOUBLE PRECISION,
INTENT(inout) :: dst(:)
393 INTEGER :: dst_size, ref_dst_size, iexch
396 ref_dst_size =
SIZE(ref_dst)
397 IF (dst_size /= ref_dst_size) &
398 CALL test_abort(
"error: ref_dst larger than dst", filename, __line__)
404 CALL wrap_a_exchange(redist, src, dst)
406 IF (cmp_arrays(dst, dble(ref_dst))) &
407 CALL test_abort(
"error in xt_redist_s_exchange1", filename, __line__)
409 END SUBROUTINE check_redist_dp_i4
411 SUBROUTINE check_redist_dp_i8(redist, src, dst, ref_dst)
412 TYPE(xt_redist),
INTENT(in) :: redist
413 DOUBLE PRECISION,
INTENT(in) :: src(:)
414 INTEGER(i8),
INTENT(in) :: ref_dst(:)
415 DOUBLE PRECISION,
INTENT(inout) :: dst(:)
416 INTEGER :: dst_size, ref_dst_size, iexch
419 ref_dst_size =
SIZE(ref_dst)
420 IF (dst_size /= ref_dst_size) &
421 CALL test_abort(
"error: ref_dst larger than dst", filename, __line__)
427 CALL wrap_a_exchange(redist, src, dst)
429 IF (cmp_arrays(dst, dble(ref_dst))) &
430 CALL test_abort(
"error in xt_redist_s_exchange1", filename, __line__)
432 END SUBROUTINE check_redist_dp_i8
434 SUBROUTINE check_redist_dp_2d(redist, src, dst, ref_dst)
435 TYPE(xt_redist),
INTENT(in) :: redist
436 DOUBLE PRECISION,
INTENT(in) :: src(:,:), ref_dst(:,:)
437 DOUBLE PRECISION,
INTENT(inout) :: dst(:,:)
438 INTEGER :: dst_size, ref_dst_size, iexch
441 ref_dst_size =
SIZE(ref_dst)
442 IF (dst_size /= ref_dst_size) &
443 CALL test_abort(
"error: ref_dst larger than dst", filename, __line__)
449 CALL wrap_a_exchange(redist, src, dst)
451 IF (cmp_arrays(dst, ref_dst)) &
452 CALL test_abort(
"error in xt_redist_s_exchange1", &
455 END SUBROUTINE check_redist_dp_2d
457 SUBROUTINE check_redist_xi(redist, src_size, src, dst_size, dst, ref_dst)
458 TYPE(xt_redist),
INTENT(in) :: redist
459 INTEGER,
INTENT(in) :: src_size, dst_size
460 INTEGER(xi),
TARGET,
INTENT(in) :: src(src_size)
461 INTEGER(xi),
INTENT(in) :: ref_dst(dst_size)
462 INTEGER(xi),
TARGET,
INTENT(inout) :: dst(dst_size)
463 CALL check_redist(redist, src, dst, ref_dst)
464 END SUBROUTINE check_redist_xi
466 SUBROUTINE check_redist_i2(redist, src, dst, ref_dst)
467 TYPE(xt_redist),
INTENT(in) :: redist
468 INTEGER(i2),
INTENT(in) :: src(:), ref_dst(:)
469 INTEGER(i2),
INTENT(inout) :: dst(:)
470 INTEGER :: dst_size, ref_dst_size, iexch
473 ref_dst_size =
SIZE(ref_dst)
474 IF (dst_size /= ref_dst_size) &
475 CALL test_abort(
"error: ref_dst larger than dst", filename, __line__)
481 CALL wrap_a_exchange(redist, src, dst)
483 IF (cmp_arrays(dst, ref_dst)) &
484 CALL test_abort(
"error in xt_redist_s_exchange1", filename, __line__)
486 END SUBROUTINE check_redist_i2
488 SUBROUTINE check_redist_i4(redist, src, dst, ref_dst)
489 TYPE(xt_redist),
INTENT(in) :: redist
490 INTEGER(i4),
INTENT(in) :: src(:), ref_dst(:)
491 INTEGER(i4),
INTENT(inout) :: dst(:)
492 INTEGER :: dst_size, ref_dst_size, iexch
495 ref_dst_size =
SIZE(ref_dst)
496 IF (dst_size /= ref_dst_size) &
497 CALL test_abort(
"error: ref_dst larger than dst", filename, __line__)
503 CALL wrap_a_exchange(redist, src, dst)
505 IF (cmp_arrays(dst, ref_dst)) &
506 CALL test_abort(
"error in xt_redist_s_exchange1", filename, __line__)
508 END SUBROUTINE check_redist_i4
510 SUBROUTINE check_redist_i8(redist, src, dst, ref_dst)
511 TYPE(xt_redist),
INTENT(in) :: redist
512 INTEGER(i8),
INTENT(in) :: src(:), ref_dst(:)
513 INTEGER(i8),
INTENT(inout) :: dst(:)
514 INTEGER :: dst_size, ref_dst_size, iexch
517 ref_dst_size =
SIZE(ref_dst)
518 IF (dst_size /= ref_dst_size) &
519 CALL test_abort(
"error: ref_dst larger than dst", filename, __line__)
525 CALL wrap_a_exchange(redist, src, dst)
527 IF (cmp_arrays(dst, ref_dst)) &
528 CALL test_abort(
"error in xt_redist_s_exchange1", filename, __line__)
530 END SUBROUTINE check_redist_i8
532 SUBROUTINE test_redist_single_array_base_dp( &
533 send_msgs, recv_msgs, src_data, ref_dst_data, comm, config)
534 TYPE(xt_redist_msg),
INTENT(in) :: send_msgs(:)
535 TYPE(xt_redist_msg),
INTENT(in) :: recv_msgs(:)
536 DOUBLE PRECISION,
INTENT(in) :: src_data(:)
537 DOUBLE PRECISION,
INTENT(in) :: ref_dst_data(:)
538 INTEGER,
INTENT(in) :: comm
539 TYPE(xt_config),
INTENT(in) :: config
541 TYPE(xt_redist) :: redist
542 INTEGER :: nsend, nrecv
546 nsend =
SIZE(send_msgs)
548 CALL test_abort(
"error in xt_redist_get_num_send_msg", &
550 nrecv =
SIZE(recv_msgs)
552 CALL test_abort(
"error in xt_redist_get_num_send_msg", &
555 IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
557 CALL test_abort(
"error in xt_redist_get_mpi_comm", filename, __line__)
558 CALL check_redist_extended(redist, src_data, ref_dst_data)
560 END SUBROUTINE test_redist_single_array_base_dp
562 SUBROUTINE check_redist_extended_dp(redist, src_data, ref_dst_data)
563 TYPE(xt_redist),
INTENT(inout) :: redist
564 DOUBLE PRECISION,
INTENT(in) :: src_data(:)
565 DOUBLE PRECISION,
INTENT(in) :: ref_dst_data(:)
567 DOUBLE PRECISION :: dst_data(SIZE(ref_dst_data))
569 TYPE(xt_redist) :: redist_copy
572 CALL check_redist(redist, src_data, dst_data, ref_dst_data)
575 CALL check_redist(redist_copy, src_data, dst_data, ref_dst_data)
578 END SUBROUTINE check_redist_extended_dp
580 FUNCTION redist_exchanger_option()
RESULT(config)
581 TYPE(xt_config) :: config
582 INTEGER :: i, num_cmd_args, arg_len
583 INTEGER :: exchanger_id
584 INTEGER,
PARAMETER :: max_opt_arg_len = 80
585 CHARACTER(max_opt_arg_len) :: optarg
587 num_cmd_args = command_argument_count()
589 DO WHILE (i < num_cmd_args)
590 CALL get_command_argument(i, optarg, arg_len)
591 IF (optarg(1:2) ==
'-m' .AND. i < num_cmd_args .AND. arg_len == 2)
THEN
592 CALL get_command_argument(i + 1, optarg, arg_len)
593 IF (arg_len > max_opt_arg_len) &
594 CALL test_abort(
'incorrect argument to command-line option -s', &
597 IF (exchanger_id == -1)
THEN
598 WRITE (0, *)
'arg to -m: ', optarg(1:arg_len)
599 CALL test_abort(
'incorrect argument to command-line option -m', &
605 WRITE (0, *)
'unexpected command-line argument parsing error: ', &
608 CALL test_abort(
'unexpected command-line argument', &
612 END FUNCTION redist_exchanger_option
614 END MODULE test_redist_common
integer, parameter, public i8
integer, parameter, public i4
integer, parameter, public i2
subroutine, public xt_request_init(request, cptr)
int xt_exchanger_id_by_name(const char *name)
void xt_config_set_exchange_method(Xt_config config, int method)
Xt_config xt_config_new(void)
void xt_idxlist_delete(Xt_idxlist idxlist)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
void xt_redist_delete(Xt_redist redist)
int xt_redist_get_num_recv_msg(Xt_redist redist)
int xt_redist_get_num_send_msg(Xt_redist redist)
void xt_redist_a_exchange1(Xt_redist redist, const void *src_data, void *dst_data, Xt_request *request)
Xt_redist xt_redist_copy(Xt_redist redist)
void xt_redist_a_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data, Xt_request *request)
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data)
void xt_redist_s_exchange1(Xt_redist redist, const void *src_data, void *dst_data)
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)
void xt_request_test(Xt_request *request, int *flag)
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)