Yet Another eXchange Tool  0.9.0
test_redist_common_f.f90
1 
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://doc.redmine.dkrz.de/yaxt/html/
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 MODULE test_redist_common
49  USE xt_core, ONLY: i2, i4, i8
50  USE iso_c_binding, ONLY: c_loc, c_int, c_char, c_null_char
51  USE mpi
52  USE yaxt, ONLY: xt_idxlist, xt_int_kind, xt_idxvec_new, xt_idxlist_delete, &
53  xt_xmap, xt_xmap_all2all_new, xt_redist, xt_redist_msg, xt_redist_copy, &
56  xt_redist_a_exchange1, xt_redist_get_mpi_comm, &
57  xt_request, xt_request_wait, xt_request_test, xt_is_null, &
59  xi => xt_int_kind, xt_config, xt_config_new, &
61 #ifdef __PGI
62  ! PGI up to at least 15.4 has a bug that prevents proper import of
63  ! multiply extended generics. This is a separate bug from the one exhibited
64  ! in 12.7 and older (see test_xmap_intersection_parallel_f.f90 for that)
69 #endif
70 #if defined(__GNUC__) && __GNUC__ < 4 || (__GNUC__ == 4 && __GNUC_MINOR__ <= 4)
71  ! gfortran 4.4 botches default initialization for xt_request
72  USE xt_requests, ONLY: xt_request_init
73  USE iso_c_binding, ONLY: c_null_ptr
74 # define REQ_DEFAULT_INIT_FIXUP(req) CALL xt_request_init(req, c_null_ptr)
75 #else
76 # define REQ_DEFAULT_INIT_FIXUP(req)
77 #endif
78  USE ftest_common, ONLY: test_abort, cmp_arrays
79  IMPLICIT NONE
80  PRIVATE
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
92 
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
100 
101  INTERFACE test_redist_single_array_base
102  MODULE PROCEDURE test_redist_single_array_base_dp
103  END INTERFACE test_redist_single_array_base
104 
105  INTERFACE check_redist_extended
106  MODULE PROCEDURE check_redist_extended_dp
107  END INTERFACE check_redist_extended
108 
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
113 
114  CHARACTER(len=*), PARAMETER :: filename = 'test_redist_common_f.f90'
115 
116 CONTAINS
117  ! build xmap for destination list containing all odd elements of
118  ! source list dimensioned 1 to src_slice_len
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
126 
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)
131  END DO
132  src_idxlist = xt_idxvec_new(index_list)
133  j = 1
134  DO i = 1, src_slice_len, dst_step
135  index_list(j) = int(i, xt_int_kind)
136  j = j + 1
137  END DO
138  dst_idxlist = xt_idxvec_new(index_list, dst_slice_len)
139  DEALLOCATE(index_list)
140 
141  xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
142  CALL xt_idxlist_delete(src_idxlist)
143  CALL xt_idxlist_delete(dst_idxlist)
144  END FUNCTION build_odd_selection_xmap
145 
146  FUNCTION communicators_are_congruent(comm1, comm2) RESULT(congruent)
147  INTEGER, INTENT(in) :: comm1, comm2
148  LOGICAL :: congruent
149 
150  INTEGER :: ierror, rcode
151 
152  CALL mpi_comm_compare(comm1, comm2, rcode, ierror)
153  congruent = ((rcode == mpi_ident) .OR. (rcode == mpi_congruent))
154  END FUNCTION communicators_are_congruent
155 
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", &
162  file, line)
163  END SUBROUTINE assert_request_is_null
164 
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", &
171  file, line)
172  END SUBROUTINE assert_request_is_not_null
173 
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)
179  CALL xt_request_wait(request)
180  CALL assert_request_is_null(request, file, line)
181  END SUBROUTINE check_wait_request
182 
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
187  LOGICAL :: flag
188  CALL xt_request_test(request, flag)
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
192 
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(:)
199 
200  IF (SIZE(src) > 0) THEN
201  src_p => src
202  ELSE
203  src_p => dummy
204  END IF
205  IF (SIZE(dst) > 0) THEN
206  dst_p => dst
207  ELSE
208  dst_p => dummy
209  END IF
210  CALL wrap_a_exchange_dp_as(redist, src_p, dst_p)
211  END SUBROUTINE wrap_a_exchange_dp
212 
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
218 
219  req_default_init_fixup(request)
220  CALL assert_request_is_null(request, filename, __line__)
221  CALL xt_redist_a_exchange1(redist, c_loc(src), c_loc(dst), request)
222  CALL check_wait_request(request, filename, __line__)
223  CALL check_test_request(request, filename, __line__)
224  END SUBROUTINE wrap_a_exchange_dp_as
225 
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
233  src_p => src
234  ELSE
235  src_p => dummy
236  END IF
237  IF (SIZE(dst) > 0) THEN
238  dst_p => dst
239  ELSE
240  dst_p => dummy
241  END IF
242  CALL wrap_a_exchange_dp_as(redist, src_p, dst_p)
243  END SUBROUTINE wrap_a_exchange_dp2d
244 
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
252  src_p => src
253  ELSE
254  src_p => dummy
255  END IF
256  IF (SIZE(dst) > 0) THEN
257  dst_p => dst
258  ELSE
259  dst_p => dummy
260  END IF
261  CALL wrap_a_exchange_i2_as(redist, src_p, dst_p)
262  END SUBROUTINE wrap_a_exchange_i2
263 
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
269 
270  req_default_init_fixup(request)
271  CALL assert_request_is_null(request, filename, __line__)
272  CALL xt_redist_a_exchange1(redist, c_loc(src), c_loc(dst), request)
273  CALL check_wait_request(request, filename, __line__)
274  CALL check_test_request(request, filename, __line__)
275  END SUBROUTINE wrap_a_exchange_i2_as
276 
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(:)
283 
284  IF (SIZE(src) > 0) THEN
285  src_p => src
286  ELSE
287  src_p => dummy
288  END IF
289  IF (SIZE(dst) > 0) THEN
290  dst_p => dst
291  ELSE
292  dst_p => dummy
293  END IF
294  CALL wrap_a_exchange_i4_as(redist, src_p, dst_p)
295  END SUBROUTINE wrap_a_exchange_i4
296 
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
302 
303  req_default_init_fixup(request)
304  CALL assert_request_is_null(request, filename, __line__)
305  CALL xt_redist_a_exchange1(redist, c_loc(src), c_loc(dst), request)
306  CALL check_wait_request(request, filename, __line__)
307  CALL check_test_request(request, filename, __line__)
308  END SUBROUTINE wrap_a_exchange_i4_as
309 
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(:)
316 
317  IF (SIZE(src) > 0) THEN
318  src_p => src
319  ELSE
320  src_p => dummy
321  END IF
322  IF (SIZE(dst) > 0) THEN
323  dst_p => dst
324  ELSE
325  dst_p => dummy
326  END IF
327  CALL wrap_a_exchange_i8_as(redist, src_p, dst_p)
328  END SUBROUTINE wrap_a_exchange_i8
329 
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
335 
336  req_default_init_fixup(request)
337  CALL assert_request_is_null(request, filename, __line__)
338  CALL xt_redist_a_exchange1(redist, c_loc(src), c_loc(dst), request)
339  CALL check_wait_request(request, filename, __line__)
340  CALL check_test_request(request, filename, __line__)
341  END SUBROUTINE wrap_a_exchange_i8_as
342 
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
348 
349  dst_size = SIZE(dst)
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__)
353  DO iexch = 1, 2
354  dst = -1.0d0
355  IF (iexch == 1) THEN
356  CALL xt_redist_s_exchange(redist, src, dst)
357  ELSE
358  CALL wrap_a_exchange(redist, src, dst)
359  ENDIF
360  IF (cmp_arrays(dst, ref_dst)) &
361  CALL test_abort("error in xt_redist_s_exchange1", filename, __line__)
362  ENDDO
363  END SUBROUTINE check_redist_dp
364 
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
371 
372  dst_size = SIZE(dst)
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__)
376  DO iexch = 1, 2
377  dst = -1.0d0
378  IF (iexch == 1) THEN
379  CALL xt_redist_s_exchange(redist, src, dst)
380  ELSE
381  CALL wrap_a_exchange(redist, src, dst)
382  ENDIF
383  IF (cmp_arrays(dst, dble(ref_dst))) &
384  CALL test_abort("error in xt_redist_s_exchange1", filename, __line__)
385  ENDDO
386  END SUBROUTINE check_redist_dp_i2
387 
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
394 
395  dst_size = SIZE(dst)
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__)
399  DO iexch = 1, 2
400  dst = -1.0d0
401  IF (iexch == 1) THEN
402  CALL xt_redist_s_exchange(redist, src, dst)
403  ELSE
404  CALL wrap_a_exchange(redist, src, dst)
405  ENDIF
406  IF (cmp_arrays(dst, dble(ref_dst))) &
407  CALL test_abort("error in xt_redist_s_exchange1", filename, __line__)
408  ENDDO
409  END SUBROUTINE check_redist_dp_i4
410 
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
417 
418  dst_size = SIZE(dst)
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__)
422  DO iexch = 1, 2
423  dst = -1.0d0
424  IF (iexch == 1) THEN
425  CALL xt_redist_s_exchange(redist, src, dst)
426  ELSE
427  CALL wrap_a_exchange(redist, src, dst)
428  ENDIF
429  IF (cmp_arrays(dst, dble(ref_dst))) &
430  CALL test_abort("error in xt_redist_s_exchange1", filename, __line__)
431  ENDDO
432  END SUBROUTINE check_redist_dp_i8
433 
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
439 
440  dst_size = SIZE(dst)
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__)
444  DO iexch = 1, 2
445  dst = -1.0d0
446  IF (iexch == 1) THEN
447  CALL xt_redist_s_exchange(redist, src, dst)
448  ELSE
449  CALL wrap_a_exchange(redist, src, dst)
450  ENDIF
451  IF (cmp_arrays(dst, ref_dst)) &
452  CALL test_abort("error in xt_redist_s_exchange1", &
453  filename, __line__)
454  ENDDO
455  END SUBROUTINE check_redist_dp_2d
456 
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
465 
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
471 
472  dst_size = SIZE(dst)
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__)
476  DO iexch = 1, 2
477  dst = -1_i2
478  IF (iexch == 1) THEN
479  CALL xt_redist_s_exchange(redist, src, dst)
480  ELSE
481  CALL wrap_a_exchange(redist, src, dst)
482  ENDIF
483  IF (cmp_arrays(dst, ref_dst)) &
484  CALL test_abort("error in xt_redist_s_exchange1", filename, __line__)
485  ENDDO
486  END SUBROUTINE check_redist_i2
487 
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
493 
494  dst_size = SIZE(dst)
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__)
498  DO iexch = 1, 2
499  dst = -1_i4
500  IF (iexch == 1) THEN
501  CALL xt_redist_s_exchange(redist, src, dst)
502  ELSE
503  CALL wrap_a_exchange(redist, src, dst)
504  ENDIF
505  IF (cmp_arrays(dst, ref_dst)) &
506  CALL test_abort("error in xt_redist_s_exchange1", filename, __line__)
507  ENDDO
508  END SUBROUTINE check_redist_i4
509 
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
515 
516  dst_size = SIZE(dst)
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__)
520  DO iexch = 1, 2
521  dst = -1_i8
522  IF (iexch == 1) THEN
523  CALL xt_redist_s_exchange(redist, src, dst)
524  ELSE
525  CALL wrap_a_exchange(redist, src, dst)
526  ENDIF
527  IF (cmp_arrays(dst, ref_dst)) &
528  CALL test_abort("error in xt_redist_s_exchange1", filename, __line__)
529  ENDDO
530  END SUBROUTINE check_redist_i8
531 
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
540 
541  TYPE(xt_redist) :: redist
542  INTEGER :: nsend, nrecv
543 
544  redist = &
545  xt_redist_single_array_base_new(send_msgs, recv_msgs, comm, config)
546  nsend = SIZE(send_msgs)
547  IF (nsend /= xt_redist_get_num_send_msg(redist)) &
548  CALL test_abort("error in xt_redist_get_num_send_msg", &
549  filename, __line__)
550  nrecv = SIZE(recv_msgs)
551  IF (nrecv /= xt_redist_get_num_recv_msg(redist)) &
552  CALL test_abort("error in xt_redist_get_num_send_msg", &
553  filename, __line__)
554  ! test communicator of redist
555  IF (.NOT. communicators_are_congruent(xt_redist_get_mpi_comm(redist), &
556  comm)) &
557  CALL test_abort("error in xt_redist_get_mpi_comm", filename, __line__)
558  CALL check_redist_extended(redist, src_data, ref_dst_data)
559 
560  END SUBROUTINE test_redist_single_array_base_dp
561 
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(:)
566 
567  DOUBLE PRECISION :: dst_data(SIZE(ref_dst_data))
568 
569  TYPE(xt_redist) :: redist_copy
570 
571  ! test exchange
572  CALL check_redist(redist, src_data, dst_data, ref_dst_data)
573  redist_copy = xt_redist_copy(redist)
574  CALL xt_redist_delete(redist)
575  CALL check_redist(redist_copy, src_data, dst_data, ref_dst_data)
576  CALL xt_redist_delete(redist_copy)
577 
578  END SUBROUTINE check_redist_extended_dp
579 
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
586  config = xt_config_new()
587  num_cmd_args = command_argument_count()
588  i = 1
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', &
595  filename, __line__)
596  exchanger_id = xt_exchanger_id_by_name(optarg)
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', &
600  filename, __line__)
601  END IF
602  CALL xt_config_set_exchange_method(config, exchanger_id)
603  i = i + 2
604  ELSE
605  WRITE (0, *) 'unexpected command-line argument parsing error: ', &
606  optarg(1:arg_len)
607  FLUSH(0)
608  CALL test_abort('unexpected command-line argument', &
609  filename, __line__)
610  END IF
611  END DO
612  END FUNCTION redist_exchanger_option
613 
614 END MODULE test_redist_common
615 !
616 ! Local Variables:
617 ! f90-continuation-indent: 5
618 ! coding: utf-8
619 ! indent-tabs-mode: nil
620 ! show-trailing-whitespace: t
621 ! require-trailing-newline: t
622 ! End:
623 !
integer, parameter, public i8
Definition: xt_core_f.f90:60
integer, parameter, public i4
Definition: xt_core_f.f90:59
integer, parameter, public i2
Definition: xt_core_f.f90:58
subroutine, public xt_request_init(request, cptr)
Definition: yaxt.f90:49
int xt_exchanger_id_by_name(const char *name)
Definition: xt_config.c:103
void xt_config_set_exchange_method(Xt_config config, int method)
Definition: xt_config.c:125
Xt_config xt_config_new(void)
Definition: xt_config.c:69
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
void xt_redist_delete(Xt_redist redist)
Definition: xt_redist.c:68
int xt_redist_get_num_recv_msg(Xt_redist redist)
Definition: xt_redist.c:102
int xt_redist_get_num_send_msg(Xt_redist redist)
Definition: xt_redist.c:97
void xt_redist_a_exchange1(Xt_redist redist, const void *src_data, void *dst_data, Xt_request *request)
Definition: xt_redist.c:91
Xt_redist xt_redist_copy(Xt_redist redist)
Definition: xt_redist.c:63
void xt_redist_a_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data, Xt_request *request)
Definition: xt_redist.c:79
void xt_redist_s_exchange(Xt_redist redist, int num_arrays, const void **src_data, void **dst_data)
Definition: xt_redist.c:73
void xt_redist_s_exchange1(Xt_redist redist, const void *src_data, void *dst_data)
Definition: xt_redist.c:86
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:65
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)