Yet Another eXchange Tool  DO_NOT_EDIT_HERE
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
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, &
54  xt_redist_s_exchange, xt_redist_s_exchange1, &
55  xi => xt_int_kind
56 #ifdef __PGI
57  ! PGI up to at least 15.4 has a bug that prevents proper import of
58  ! multiply extended generics. This is a separate bug from the one exhibited
59  ! in 12.7 and older (see test_xmap_intersection_parallel_f.f90 for that)
60  USE xt_redist_real_dp, ONLY: xt_redist_s_exchange
61  USE xt_redist_int_i2, ONLY: xt_redist_s_exchange
62  USE xt_redist_int_i4, ONLY: xt_redist_s_exchange
63  USE xt_redist_int_i8, ONLY: xt_redist_s_exchange
64 #endif
65  USE ftest_common, ONLY: test_abort
66  IMPLICIT NONE
67  PRIVATE
68  INTERFACE check_redist
69  MODULE PROCEDURE check_redist_dp
70  MODULE PROCEDURE check_redist_dp2_i2
71  MODULE PROCEDURE check_redist_dp2_i4
72  MODULE PROCEDURE check_redist_dp2_i8
73  MODULE PROCEDURE check_redist_dp2
74  MODULE PROCEDURE check_redist_dp2_2d
75  MODULE PROCEDURE check_redist_xi
76  MODULE PROCEDURE check_redist_i2
77  MODULE PROCEDURE check_redist_i4
78  MODULE PROCEDURE check_redist_i8
79  END INTERFACE check_redist
80  PUBLIC :: build_odd_selection_xmap, check_redist, communicators_are_congruent
81  PUBLIC :: check_redist_xi
82 CONTAINS
83  ! build xmap for destination list containing all odd elements of
84  ! source list dimensioned 1 to src_slice_len
85  FUNCTION build_odd_selection_xmap(src_slice_len) RESULT(xmap)
86  INTEGER, INTENT(in) :: src_slice_len
87  TYPE(xt_xmap) :: xmap
88  INTEGER :: i, j, dst_slice_len
89  INTEGER, PARAMETER :: dst_step = 2
90  INTEGER(xt_int_kind), ALLOCATABLE :: index_list(:)
91  TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
92 
93  dst_slice_len = (src_slice_len + dst_step - 1)/dst_step
94  ALLOCATE(index_list(src_slice_len))
95  DO i = 1, src_slice_len
96  index_list(i) = int(i, xt_int_kind)
97  END DO
98  src_idxlist = xt_idxvec_new(index_list)
99  j = 1
100  DO i = 1, src_slice_len, dst_step
101  index_list(j) = int(i, xt_int_kind)
102  j = j + 1
103  END DO
104  dst_idxlist = xt_idxvec_new(index_list, dst_slice_len)
105  DEALLOCATE(index_list)
106 
107  xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
108  CALL xt_idxlist_delete(src_idxlist)
109  CALL xt_idxlist_delete(dst_idxlist)
110  END FUNCTION build_odd_selection_xmap
111 
112  FUNCTION communicators_are_congruent(comm1, comm2) RESULT(congruent)
113  INTEGER, INTENT(in) :: comm1, comm2
114  LOGICAL :: congruent
115 
116  INTEGER :: ierror, rcode
117 
118  CALL mpi_comm_compare(comm1, comm2, rcode, ierror)
119  congruent = ((rcode == mpi_ident) .OR. (rcode == mpi_congruent))
120  END FUNCTION communicators_are_congruent
121 
122  SUBROUTINE check_redist_dp(redist, src, dst_size, dst, ref_dst)
123  TYPE(xt_redist), INTENT(in) :: redist
124  INTEGER, INTENT(in) :: dst_size
125  DOUBLE PRECISION, TARGET, INTENT(in) :: src(*)
126  DOUBLE PRECISION, INTENT(in) :: ref_dst(dst_size)
127  DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(dst_size)
128  dst = -1.0d0
129  CALL xt_redist_s_exchange1(redist, c_loc(src), c_loc(dst))
130  IF (any(dst /= ref_dst)) &
131  CALL test_abort("error in xt_redist_s_exchange1", &
132  __file__, &
133  __line__)
134  END SUBROUTINE check_redist_dp
135 
136  SUBROUTINE check_redist_dp2(redist, src, dst, ref_dst)
137  TYPE(xt_redist), INTENT(in) :: redist
138  DOUBLE PRECISION, INTENT(in) :: src(:)
139  DOUBLE PRECISION, INTENT(in) :: ref_dst(:)
140  DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(:)
141 
142  INTEGER :: dst_size, ref_dst_size
143  dst_size = SIZE(dst)
144  ref_dst_size = SIZE(ref_dst)
145  IF (dst_size /= ref_dst_size) &
146  CALL test_abort("error: ref_dst larger than dst", &
147  __file__, &
148  __line__)
149  dst = -1.0d0
150  CALL xt_redist_s_exchange(redist, src, dst)
151  IF (any(dst /= ref_dst)) &
152  CALL test_abort("error in xt_redist_s_exchange", &
153  __file__, &
154  __line__)
155  END SUBROUTINE check_redist_dp2
156 
157  SUBROUTINE check_redist_dp2_i2(redist, src, dst, ref_dst)
158  TYPE(xt_redist), INTENT(in) :: redist
159  DOUBLE PRECISION, INTENT(in) :: src(:)
160  INTEGER(i2), INTENT(in) :: ref_dst(:)
161  DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(:)
162 
163  INTEGER :: dst_size, ref_dst_size
164  dst_size = SIZE(dst)
165  ref_dst_size = SIZE(ref_dst)
166  IF (dst_size /= ref_dst_size) &
167  CALL test_abort("error: ref_dst larger than dst", &
168  __file__, &
169  __line__)
170  dst = -1.0d0
171  CALL xt_redist_s_exchange(redist, src, dst)
172  IF (any(dst /= dble(ref_dst))) &
173  CALL test_abort("error in xt_redist_s_exchange", &
174  __file__, &
175  __line__)
176  END SUBROUTINE check_redist_dp2_i2
177 
178  SUBROUTINE check_redist_dp2_i4(redist, src, dst, ref_dst)
179  TYPE(xt_redist), INTENT(in) :: redist
180  DOUBLE PRECISION, INTENT(in) :: src(:)
181  INTEGER(i4), INTENT(in) :: ref_dst(:)
182  DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(:)
183 
184  INTEGER :: dst_size, ref_dst_size
185  dst_size = SIZE(dst)
186  ref_dst_size = SIZE(ref_dst)
187  IF (dst_size /= ref_dst_size) &
188  CALL test_abort("error: ref_dst larger than dst", &
189  __file__, &
190  __line__)
191  dst = -1.0d0
192  CALL xt_redist_s_exchange(redist, src, dst)
193  IF (any(dst /= dble(ref_dst))) &
194  CALL test_abort("error in xt_redist_s_exchange", &
195  __file__, &
196  __line__)
197  END SUBROUTINE check_redist_dp2_i4
198 
199  SUBROUTINE check_redist_dp2_i8(redist, src, dst, ref_dst)
200  TYPE(xt_redist), INTENT(in) :: redist
201  DOUBLE PRECISION, INTENT(in) :: src(:)
202  INTEGER(i8), INTENT(in) :: ref_dst(:)
203  DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(:)
204 
205  INTEGER :: dst_size, ref_dst_size
206  dst_size = SIZE(dst)
207  ref_dst_size = SIZE(ref_dst)
208  IF (dst_size /= ref_dst_size) &
209  CALL test_abort("error: ref_dst larger than dst", &
210  __file__, &
211  __line__)
212  dst = -1.0d0
213  CALL xt_redist_s_exchange(redist, src, dst)
214  IF (any(dst /= dble(ref_dst))) &
215  CALL test_abort("error in xt_redist_s_exchange", &
216  __file__, &
217  __line__)
218  END SUBROUTINE check_redist_dp2_i8
219 
220  SUBROUTINE check_redist_dp2_2d(redist, src, dst, ref_dst)
221  TYPE(xt_redist), INTENT(in) :: redist
222  DOUBLE PRECISION, INTENT(in) :: src(:,:)
223  DOUBLE PRECISION, INTENT(in) :: ref_dst(:,:)
224  DOUBLE PRECISION, TARGET, INTENT(inout) :: dst(:,:)
225 
226  INTEGER :: dst_size, ref_dst_size
227  dst_size = SIZE(dst)
228  ref_dst_size = SIZE(ref_dst)
229  IF (dst_size /= ref_dst_size) &
230  CALL test_abort("error: ref_dst larger than dst", &
231  __file__, &
232  __line__)
233  dst = -1.0d0
234  CALL xt_redist_s_exchange(redist, src, dst)
235  IF (any(dst /= ref_dst)) &
236  CALL test_abort("error in xt_redist_s_exchange", &
237  __file__, &
238  __line__)
239  END SUBROUTINE check_redist_dp2_2d
240 
241  SUBROUTINE check_redist_xi(redist, src, dst_size, dst, ref_dst)
242  TYPE(xt_redist), INTENT(in) :: redist
243  INTEGER, INTENT(in) :: dst_size
244  INTEGER(xi), TARGET, INTENT(in) :: src(*)
245  INTEGER(xi), INTENT(in) :: ref_dst(dst_size)
246  INTEGER(xi), TARGET, INTENT(inout) :: dst(dst_size)
247  dst = -1_xi
248  CALL xt_redist_s_exchange1(redist, c_loc(src), c_loc(dst))
249  IF (any(dst /= ref_dst)) &
250  CALL test_abort("error in xt_redist_s_exchange1", &
251  __file__, &
252  __line__)
253  END SUBROUTINE check_redist_xi
254 
255  SUBROUTINE check_redist_i2(redist, src, dst, ref_dst)
256  TYPE(xt_redist), INTENT(in) :: redist
257  INTEGER(i2), INTENT(in) :: src(:)
258  INTEGER(i2), INTENT(in) :: ref_dst(:)
259  INTEGER(i2), TARGET, INTENT(inout) :: dst(:)
260 
261  INTEGER :: dst_size, ref_dst_size
262  dst_size = SIZE(dst)
263  ref_dst_size = SIZE(ref_dst)
264  IF (dst_size /= ref_dst_size) &
265  CALL test_abort("error: ref_dst larger than dst", &
266  __file__, &
267  __line__)
268  dst = -1_i2
269  CALL xt_redist_s_exchange(redist, src, dst)
270  IF (any(dst /= ref_dst)) &
271  CALL test_abort("error in xt_redist_s_exchange", &
272  __file__, &
273  __line__)
274  END SUBROUTINE check_redist_i2
275 
276  SUBROUTINE check_redist_i4(redist, src, dst, ref_dst)
277  TYPE(xt_redist), INTENT(in) :: redist
278  INTEGER(i4), INTENT(in) :: src(:)
279  INTEGER(i4), INTENT(in) :: ref_dst(:)
280  INTEGER(i4), TARGET, INTENT(inout) :: dst(:)
281 
282  INTEGER :: dst_size, ref_dst_size
283  dst_size = SIZE(dst)
284  ref_dst_size = SIZE(ref_dst)
285  IF (dst_size /= ref_dst_size) &
286  CALL test_abort("error: ref_dst larger than dst", &
287  __file__, &
288  __line__)
289  dst = -1_i4
290  CALL xt_redist_s_exchange(redist, src, dst)
291  IF (any(dst /= ref_dst)) &
292  CALL test_abort("error in xt_redist_s_exchange", &
293  __file__, &
294  __line__)
295  END SUBROUTINE check_redist_i4
296 
297  SUBROUTINE check_redist_i8(redist, src, dst, ref_dst)
298  TYPE(xt_redist), INTENT(in) :: redist
299  INTEGER(i8), INTENT(in) :: src(:)
300  INTEGER(i8), INTENT(in) :: ref_dst(:)
301  INTEGER(i8), TARGET, INTENT(inout) :: dst(:)
302 
303  INTEGER :: dst_size, ref_dst_size
304  dst_size = SIZE(dst)
305  ref_dst_size = SIZE(ref_dst)
306  IF (dst_size /= ref_dst_size) &
307  CALL test_abort("error: ref_dst larger than dst", &
308  __file__, &
309  __line__)
310  dst = -1_i8
311  CALL xt_redist_s_exchange(redist, src, dst)
312  IF (any(dst /= ref_dst)) &
313  CALL test_abort("error in xt_redist_s_exchange", &
314  __file__, &
315  __line__)
316  END SUBROUTINE check_redist_i8
317 
318 END MODULE test_redist_common
319 !
320 ! Local Variables:
321 ! f90-continuation-indent: 5
322 ! coding: utf-8
323 ! indent-tabs-mode: nil
324 ! show-trailing-whitespace: t
325 ! require-trailing-newline: t
326 ! End:
327 !
Generated by   doxygen 1.8.13