Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_redist_collection_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://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
49#include "fc_feature_defs.inc"
50PROGRAM test_redist_collection
51 USE mpi
52 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort, cmp_arrays
53 USE test_idxlist_utils, ONLY: test_err_count
54 USE yaxt, ONLY: xt_initialize, xt_finalize, &
61#if !defined HAVE_FC_LOGICAL_INTEROP || !defined(__GNUC__) || __GNUC__ > 4 \
62 || (__gnuc__ == 4 && __gnuc_minor__ > 8)
63#else
64 USE yaxt, ONLY: xt_slice_c_loc
65#endif
66 ! older PGI compilers do not handle generic interface correctly
67#if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
68 USE xt_redist_base, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
69#endif
70 USE test_redist_common, ONLY: build_odd_selection_xmap, check_redist, &
71 check_wait_request, redist_exchanger_option
72 USE iso_c_binding, ONLY: c_loc, c_ptr
73 USE redist_collection_displace, ONLY: test_displacement_variations
74#include "xt_slice_c_loc.inc"
75 IMPLICIT NONE
76 CHARACTER(len=*), PARAMETER :: filename = 'test_redist_collection_f.f90'
77 CHARACTER(len=*), PARAMETER :: err_msg(2) = &
78 (/ "error on xt_redist_s_exchange", "error on xt_redist_a_exchange" /)
79 TYPE(xt_config) :: config
80
81 CALL init_mpi
82 CALL xt_initialize(mpi_comm_world)
83 config = redist_exchanger_option()
84
85 CALL simple_test(mpi_comm_world, config)
86 CALL simple_test2(mpi_comm_world, config)
87 CALL test_empty_redist(mpi_comm_world, config)
88 CALL test_repeated_redist(mpi_comm_world, config, -1)
89 CALL test_repeated_redist(mpi_comm_world, config, 0)
90 CALL test_displacement_variations(mpi_comm_world, config)
91
92 IF (test_err_count() /= 0) &
93 CALL test_abort("non-zero error count!", filename, __line__)
94 CALL xt_config_delete(config)
95 CALL xt_finalize
96 CALL finish_mpi
97CONTAINS
98 SUBROUTINE simple_test(comm, config)
99 ! general test with one redist
100 INTEGER, INTENT(in) :: comm
101 TYPE(xt_config), INTENT(in) :: config
102 ! set up data
103 TYPE(xt_xmap) :: xmap
104 TYPE(xt_redist) :: redist, redist_coll, redist_copy
105 INTEGER, PARAMETER :: src_slice_len = 5, dst_slice_len = 3
106 DOUBLE PRECISION, PARAMETER :: &
107 ref_dst_data(dst_slice_len) = (/ 1.0d0, 3.0d0, 5.0d0 /), &
108 src_data(src_slice_len) = (/ 1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0 /)
109 DOUBLE PRECISION :: dst_data(dst_slice_len)
110
111
112 xmap = build_odd_selection_xmap(src_slice_len, comm)
113
114 redist = xt_redist_p2p_new(xmap, mpi_double_precision)
115 CALL xt_xmap_delete(xmap)
116 redist_copy = xt_redist_copy(redist)
117 CALL xt_redist_delete(redist)
118 redist = redist_copy
119
120 ! generate redist_collection
121 redist_coll = xt_redist_collection_new((/ redist /), 1, -1, comm, config)
122
123 CALL xt_redist_delete(redist)
124
125 ! test exchange
126 CALL check_redist(redist_coll, src_data, dst_data, ref_dst_data)
127
128 ! clean up
129 CALL xt_redist_delete(redist_coll)
130 END SUBROUTINE simple_test
131
132 SUBROUTINE simple_test2(comm, config)
133 ! general test with one redist
134 INTEGER, INTENT(in) :: comm
135 TYPE(xt_config), INTENT(in) :: config
136 ! set up data
137 TYPE(xt_xmap) :: xmap
138 TYPE(xt_redist) :: redist_coll, redist_copy, &
139 redist_components(2)
140 INTEGER, PARAMETER :: src_slice_len = 5, dst_slice_len = 3
141 TYPE src_data_collection
142 DOUBLE PRECISION :: dp(src_slice_len)
143 LOGICAL :: l(src_slice_len)
144 END TYPE src_data_collection
145 TYPE dst_data_collection
146 DOUBLE PRECISION :: dp(dst_slice_len)
147 LOGICAL :: l(dst_slice_len)
148 END TYPE dst_data_collection
149 TYPE(src_data_collection), SAVE, TARGET :: src_data = src_data_collection(&
150 (/ 1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0 /), &
151 (/ .true., .false., .true., .false., .true. /))
152 TYPE(dst_data_collection), PARAMETER :: &
153 ref_dst_data = dst_data_collection((/ 1.0d0, 3.0d0, 5.0d0 /), &
154 (/ .true., .true., .true. /))
155 TYPE(dst_data_collection), TARGET :: dst_data
156 TYPE(c_ptr) :: src_data_p(2), dst_data_p(2)
157
158 xmap = build_odd_selection_xmap(src_slice_len, comm)
159
160 redist_components(1) = xt_redist_p2p_new(xmap, mpi_double_precision)
161 redist_components(2) = xt_redist_p2p_new(xmap, mpi_logical)
162 CALL xt_xmap_delete(xmap)
163
164 ! generate redist_collection
165 redist_coll = xt_redist_collection_new(redist_components, comm, config)
166 CALL xt_redist_delete(redist_components)
167 redist_copy = xt_redist_copy(redist_coll)
168 CALL xt_redist_delete(redist_coll)
169 redist_coll = redist_copy
170
171 ! test exchange
172 ! GNU Fortran versions up to 4.8 cannot call c_loc for type components,
173 ! instant ICE, and
174#if !defined(__GNUC__) || __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ > 8)
175# define COMP_C_LOC(v, p) p = C_LOC(v)
176#else
177# define COMP_C_LOC(v, p) CALL xt_slice_c_loc(v, p)
178#endif
179 ! some compilers won't create c_ptr's to LOGICALs and gfortran
180 ! version 8 and below has a bug that prevents it from noticing the escaped
181 ! pointer (and computes ANY(dst_data%l .NEQV. ref_dst_data%l early
182 ! for that reason).
183#if defined HAVE_FC_LOGICAL_INTEROP && ( !defined __GNUC__ || __GNUC__ > 8 )
184# define L_COMP_C_LOC(v, p) p = C_LOC(v)
185#else
186# define L_COMP_C_LOC(v, p) CALL xt_slice_c_loc(v, p)
187#endif
188
189 comp_c_loc(src_data%dp, src_data_p(1))
190 l_comp_c_loc(src_data%l, src_data_p(2))
191 dst_data%dp = -1.0d0
192 dst_data%l = .false.
193 comp_c_loc(dst_data%dp, dst_data_p(1))
194 l_comp_c_loc(dst_data%l, dst_data_p(2))
195 CALL xt_redist_s_exchange(redist_coll, src_data_p, dst_data_p)
196 IF (any(dst_data%l .NEQV. ref_dst_data%l)) &
197 CALL test_abort("error in xt_redist_s_exchange", filename, __line__)
198 IF (cmp_arrays(dst_data%dp, ref_dst_data%dp)) &
199 CALL test_abort("error in xt_redist_s_exchange", filename, __line__)
200
201 ! clean up
202 CALL xt_redist_delete(redist_coll)
203 END SUBROUTINE simple_test2
204
205 SUBROUTINE test_empty_redist(comm, config)
206 ! general test with empty redist
207 INTEGER, INTENT(in) :: comm
208 TYPE(xt_config), INTENT(in) :: config
209 ! set up data
210 TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
211 TYPE(xt_xmap) :: xmap
212 TYPE(xt_redist) :: redist, redist_coll, redist_copy
213
214
215 src_idxlist = xt_idxempty_new()
216 dst_idxlist = xt_idxempty_new()
217
218 xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, comm)
219
220 CALL xt_idxlist_delete(src_idxlist)
221 CALL xt_idxlist_delete(dst_idxlist)
222
223 redist = xt_redist_p2p_new(xmap, mpi_double_precision)
224 CALL xt_xmap_delete(xmap)
225 redist_copy = xt_redist_copy(redist)
226 CALL xt_redist_delete(redist)
227 redist = redist_copy
228
229 ! generate redist_collection
230 redist_coll = xt_redist_collection_new((/ redist /), 1, -1, comm, config)
231
232 CALL xt_redist_delete(redist)
233
234 ! clean up
235 CALL xt_redist_delete(redist_coll)
236 END SUBROUTINE test_empty_redist
237
238 SUBROUTINE test_repeated_redist_ds(redist_coll, src_data, permutation)
239 TYPE(xt_redist), INTENT(in) :: redist_coll
240 DOUBLE PRECISION, INTENT(in), TARGET :: src_data(5, 3)
241 INTEGER, INTENT(in) :: permutation(3)
242 INTEGER :: i, j
243 DOUBLE PRECISION, PARAMETER :: ref_dst_data(3, 3) &
244 = reshape((/ ((dble(i + j), i = 1,5,2), j = 0,10,5) /), (/ 3, 3 /))
245 DOUBLE PRECISION, TARGET :: dst_data(3, 3)
246 TYPE(c_ptr) :: src_data_p(3), dst_data_p(3)
247
248 INTEGER :: iexch
249 TYPE(xt_request) :: request
250
251 DO i = 1, 3
252 xt_slice_c_loc(src_data(:, permutation(i)), src_data_p(i))
253 xt_slice_c_loc(dst_data(:, permutation(i)), dst_data_p(i))
254 END DO
255 DO iexch = 1, 2
256 dst_data = -1.0d0
257 IF (iexch == 1) THEN
258 CALL xt_redist_s_exchange(redist_coll, 3, src_data_p, dst_data_p)
259 ELSE
260 CALL xt_redist_a_exchange(redist_coll, 3, src_data_p, dst_data_p, &
261 request)
262 CALL check_wait_request(request, filename, __line__)
263 ENDIF
264 IF (cmp_arrays(ref_dst_data, dst_data)) &
265 CALL test_abort(err_msg(iexch), filename, __line__)
266 ENDDO
267 END SUBROUTINE test_repeated_redist_ds
268
269 SUBROUTINE test_repeated_redist(comm, config, cache_size)
270 INTEGER, INTENT(in) :: comm
271 TYPE(xt_config), INTENT(in) :: config
272 INTEGER, INTENT(in) :: cache_size
273 ! test with one redist used three times (with two different input data
274 ! displacements -> test of cache) (with default cache size)
275 ! set up data
276 INTEGER, PARAMETER :: num_slice = 3
277 INTEGER, PARAMETER :: src_slice_len = 5
278 INTEGER :: i
279 DOUBLE PRECISION, PARAMETER :: src_data(5, num_slice) = reshape((/&
280 (dble(i), i = 1, 15)/), (/ 5, num_slice /))
281 TYPE(xt_xmap) :: xmap
282 TYPE(xt_redist) :: redists(num_slice), redist_coll, redist_coll_copy
283 INTEGER, PARAMETER :: permutation(3, 3) &
284 = reshape((/ 1, 2, 3, 2, 1, 3, 1, 2, 3 /), (/ 3, 3 /))
285
286 xmap = build_odd_selection_xmap(src_slice_len, comm)
287
288 redists = xt_redist_p2p_new(xmap, mpi_double_precision)
289
290 CALL xt_xmap_delete(xmap)
291
292 ! generate redist_collection
293
294 redist_coll = xt_redist_collection_new(redists, 3, cache_size, &
295 comm, config)
296
297 CALL xt_redist_delete(redists(1))
298
299 DO i = 1, 3
300 ! test exchange, first with simple sequence, then permuted
301 ! offsets and then original offsets again
302 CALL test_repeated_redist_ds(redist_coll, src_data, permutation(:, i))
303 END DO
304
305 ! and the copy
306 redist_coll_copy = xt_redist_copy(redist_coll)
307 CALL xt_redist_delete(redist_coll)
308 DO i = 1, 3
309 ! test exchange, first with simple sequence, then permuted
310 ! offsets and then original offsets again
311 CALL test_repeated_redist_ds(redist_coll_copy, src_data, permutation(:, i))
312 END DO
313
314 ! clean up
315 CALL xt_redist_delete(redist_coll_copy)
316 END SUBROUTINE test_repeated_redist
317
318END PROGRAM test_redist_collection
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!
void xt_config_delete(Xt_config config)
Definition xt_config.c:85
void xt_initialize(MPI_Comm default_comm)
Definition xt_init.c:70
void xt_finalize(void)
Definition xt_init.c:92
Xt_idxlist xt_idxempty_new(void)
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
void xt_redist_delete(Xt_redist redist)
Definition xt_redist.c:74
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_a_exchange(Xt_redist redist, int num_arrays, const void *const src_data[], void *const dst_data[], Xt_request *request)
Xt_redist xt_redist_collection_new(Xt_redist *redists, int num_redists, int cache_size, MPI_Comm comm)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
void xt_xmap_delete(Xt_xmap xmap)
Definition xt_xmap.c:86
Xt_xmap xt_xmap_all2all_new(Xt_idxlist src_idxlist, Xt_idxlist dst_idxlist, MPI_Comm comm)