Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
test_redist_repeat_f.f90
1!>
2!! @file test_redist_repeat_f.f90
3!! @brief Fortran test of redist_repeatection_static class
4!!
5!! @copyright Copyright (C) 2016 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"
49PROGRAM test_redist_repeat
50 USE mpi
51 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort, cmp_arrays
52 USE test_idxlist_utils, ONLY: test_err_count
58#if defined __PGI && ( __PGIC__ == 15 || __PGIC__ == 14 )
59 USE xt_redist_real_sp, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
60 USE xt_redist_real_dp, ONLY: xt_redist_s_exchange, xt_redist_a_exchange
61#endif
62 USE test_redist_common, ONLY: build_odd_selection_xmap, check_redist, &
63 check_wait_request, redist_exchanger_option
64 USE iso_c_binding, ONLY: c_int
65 IMPLICIT NONE
66 CHARACTER(len=*), PARAMETER :: filename = 'test_redist_repeat_f.f90'
67 CHARACTER(len=*), PARAMETER :: exch1name(2) = &
68 (/ "xt_redist_s_exchange1", "xt_redist_a_exchange1" /)
69 TYPE(xt_config) :: config
70
71 CALL init_mpi
72 CALL xt_initialize(mpi_comm_world)
73 config = redist_exchanger_option()
74
75 CALL simple_test(mpi_comm_world, config)
76 CALL test_repeated_redist(mpi_comm_world, config)
77 CALL test_repeated_redist_with_gap(mpi_comm_world, config)
78 CALL test_repeated_overlapping_redist(mpi_comm_world, config)
79 CALL test_repeated_redist_asym(mpi_comm_world, config)
80
81 IF (test_err_count() /= 0) &
82 CALL test_abort("non-zero error count!", filename, __line__)
83 CALL xt_config_delete(config)
84 CALL xt_finalize
85 CALL finish_mpi
86CONTAINS
87 SUBROUTINE simple_test(comm, config)
88 INTEGER, INTENT(in) :: comm
89 TYPE(xt_config), INTENT(in) :: config
90 ! general test with one redist
91 ! set up data
92 TYPE(xt_xmap) :: xmap
93 TYPE(xt_redist) :: redist, redist_repeat
94 INTEGER, PARAMETER :: src_slice_len = 5, dst_slice_len = 3
95 DOUBLE PRECISION, PARAMETER :: ref_dst_data(dst_slice_len) &
96 = (/ 1.0d0, 3.0d0, 5.0d0 /), &
97 src_data(src_slice_len) = (/ 1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0 /)
98 DOUBLE PRECISION :: dst_data(dst_slice_len)
99 INTEGER(mpi_address_kind) :: src_extent, dst_extent
100 INTEGER(mpi_address_kind) :: base_address, temp_address
101 INTEGER(c_int) :: displacements(1) = 0
102 INTEGER :: ierror
103
104 xmap = build_odd_selection_xmap(src_slice_len, comm)
105
106 redist = xt_redist_p2p_new(xmap, mpi_double_precision)
107
108 CALL xt_xmap_delete(xmap)
109
110 CALL mpi_get_address(src_data(1), base_address, ierror)
111 IF (ierror /= mpi_success) &
112 CALL test_abort('mpi_get_address failed', filename, __line__)
113 CALL mpi_get_address(src_data(2), temp_address, ierror)
114 IF (ierror /= mpi_success) &
115 CALL test_abort('mpi_get_address failed', filename, __line__)
116 src_extent = (temp_address - base_address) * src_slice_len
117 CALL mpi_get_address(dst_data(1), base_address, ierror)
118 IF (ierror /= mpi_success) &
119 CALL test_abort('mpi_get_address failed', filename, __line__)
120 CALL mpi_get_address(dst_data(2), temp_address, ierror)
121 IF (ierror /= mpi_success) &
122 CALL test_abort('mpi_get_address failed', filename, __line__)
123 dst_extent = (temp_address - base_address) * dst_slice_len
124
125 ! generate redist_repeat
126 redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, 1, &
127 displacements, config)
128
129 CALL xt_redist_delete(redist)
130
131 ! test exchange
132 CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
133
134 ! clean up
135 CALL xt_redist_delete(redist_repeat)
136 END SUBROUTINE simple_test
137
138 SUBROUTINE test_repeated_redist_ds1(redist_repeat)
139 TYPE(xt_redist), INTENT(in) :: redist_repeat
140 INTEGER :: i, j
141 DOUBLE PRECISION, PARAMETER :: src_data(5, 3) = reshape((/&
142 (dble(i), i = 1, 15)/), (/ 5, 3 /))
143 DOUBLE PRECISION, PARAMETER :: ref_dst_data(3, 3) &
144 = reshape((/ ((dble(i + j), i = 1,5,2), j = 0,10,5) /), (/ 3, 3 /))
145 DOUBLE PRECISION :: dst_data(3, 3)
146
147 CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
148 END SUBROUTINE test_repeated_redist_ds1
149
150#ifdef __PGI
151# define NO_2D_PARAM
152#elif defined(_CRAYFTN)
153# if _RELEASE_MAJOR < 8 || (_RELEASE_MAJOR == 8 && _RELEASE_MINOR < 7)
154# define NO_2D_PARAM
155# endif
156#endif
157
158 SUBROUTINE test_repeated_redist_ds1_with_gap(redist_repeat)
159 TYPE(xt_redist), INTENT(in) :: redist_repeat
160 INTEGER :: i, j
161 DOUBLE PRECISION, PARAMETER :: src_data(5, 5) = reshape((/&
162 (dble(i), i = 1, 25)/), (/ 5, 5 /))
163 DOUBLE PRECISION :: dst_data(3, 5)
164#ifdef NO_2D_PARAM
165 DOUBLE PRECISION :: ref_dst_data(3, 5)
166 ref_dst_data &
167 = reshape((/ ((dble((i + j)*mod(j+1,2)-mod(j,2)), i = 1,5,2), &
168 j = 0,20,5) /), (/ 3, 5 /))
169#else
170 DOUBLE PRECISION, PARAMETER :: ref_dst_data(3, 5) &
171 = reshape((/ ((dble((i + j)*mod(j+1,2)-mod(j,2)), i = 1,5,2), j = 0,20,5) /), (/ 3, 5 /))
172#endif
173 CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
174 END SUBROUTINE test_repeated_redist_ds1_with_gap
175
176 SUBROUTINE test_repeated_redist_ds2(redist_repeat)
177 TYPE(xt_redist), INTENT(in) :: redist_repeat
178 INTEGER :: i, j
179 DOUBLE PRECISION, PARAMETER :: src_data(5, 3) = reshape((/&
180 (dble(i), i = 20, 34)/), (/ 5, 3 /))
181 DOUBLE PRECISION, PARAMETER :: ref_dst_data(3, 3) &
182 = reshape((/ ((dble(i + j), i = 1,5,2), j = 19,33,5) /), (/ 3, 3 /))
183 DOUBLE PRECISION :: dst_data(3, 3)
184
185 CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
186 END SUBROUTINE test_repeated_redist_ds2
187
188 SUBROUTINE test_repeated_redist(comm, config)
189 INTEGER, INTENT(in) :: comm
190 TYPE(xt_config), INTENT(in) :: config
191 ! test with one redist used three times (with two different input data
192 ! displacements -> test of cache) (with default cache size)
193 ! set up data
194 INTEGER, PARAMETER :: num_slice = 3
195 INTEGER, PARAMETER :: src_slice_len = 5
196 TYPE(xt_xmap) :: xmap
197 TYPE(xt_redist) :: redist, redist_repeat
198 INTEGER(mpi_address_kind) :: src_extent, dst_extent
199 INTEGER(mpi_address_kind) :: base_address, temp_address
200 INTEGER(c_int), PARAMETER :: &
201 displacements(3)= (/ 0_c_int, 1_c_int, 2_c_int /)
202 DOUBLE PRECISION, TARGET :: src_template(5, 3), dst_template(3, 3)
203 INTEGER :: ierror
204
205 xmap = build_odd_selection_xmap(src_slice_len, comm)
206
207 redist = xt_redist_p2p_new(xmap, mpi_double_precision)
208
209 CALL xt_xmap_delete(xmap)
210
211 ! generate redist_repeat
212 CALL mpi_get_address(src_template(1,1), base_address, ierror)
213 IF (ierror /= mpi_success) &
214 CALL test_abort('mpi_get_address failed', filename, __line__)
215 CALL mpi_get_address(src_template(1,2), temp_address, ierror)
216 IF (ierror /= mpi_success) &
217 CALL test_abort('mpi_get_address failed', filename, __line__)
218 src_extent = temp_address - base_address
219 CALL mpi_get_address(dst_template(1,1), base_address, ierror)
220 IF (ierror /= mpi_success) &
221 CALL test_abort('mpi_get_address failed', filename, __line__)
222 CALL mpi_get_address(dst_template(1,2), temp_address, ierror)
223 IF (ierror /= mpi_success) &
224 CALL test_abort('mpi_get_address failed', filename, __line__)
225 dst_extent = temp_address - base_address
226
227 redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, &
228 num_slice, displacements, config)
229 CALL xt_redist_delete(redist)
230
231 ! test exchange
232 CALL test_repeated_redist_ds1(redist_repeat)
233 ! test exchange
234 CALL test_repeated_redist_ds2(redist_repeat)
235 ! clean up
236 CALL xt_redist_delete(redist_repeat)
237 END SUBROUTINE test_repeated_redist
238
239 SUBROUTINE test_repeated_redist_asym(comm, config)
240 INTEGER, INTENT(in) :: comm
241 TYPE(xt_config), INTENT(in) :: config
242 ! test asymmetric variant of redist_repeat
243
244 INTEGER, PARAMETER :: num_slice = 3
245 INTEGER, PARAMETER :: src_slice_len = 5
246 TYPE(xt_xmap) :: xmap
247 TYPE(xt_redist) :: redist, redist_repeat
248 INTEGER(mpi_address_kind) :: src_extent, dst_extent
249 INTEGER(mpi_address_kind) :: base_address, temp_address
250 INTEGER(c_int) :: src_displacements(3), dst_displacements(3)
251 INTEGER :: i, ierror
252 DOUBLE PRECISION, PARAMETER :: &
253 ref_dst_data(3, 3) = reshape([ 6.0d0, 8.0d0, 10.0d0, 11.0d0, 13.0d0, &
254 & 15.0d0, 1.0d0, 3.0d0, 5.0d0 ], [3,3] )
255 DOUBLE PRECISION, TARGET :: dst_data(3, 3)
256 DOUBLE PRECISION, TARGET, SAVE :: &
257 src_data(5, 3) = reshape([(dble(i), i = 1, 15)], [5,3])
258 INTEGER, PARAMETER :: dp = kind(src_data)
259
260 ! xmap: [1,2,3,4,5] -> [1,3,5]
261 xmap = build_odd_selection_xmap(src_slice_len, comm)
262
263 redist = xt_redist_p2p_new(xmap, mpi_double_precision)
264
265 CALL xt_xmap_delete(xmap)
266
267 ! generate redist_repeat:
268 CALL mpi_get_address(src_data(1,1), base_address, ierror)
269 CALL mpi_get_address(src_data(1,2), temp_address, ierror)
270 src_extent = temp_address - base_address
271 CALL mpi_get_address(dst_data(1,1), base_address, ierror)
272 CALL mpi_get_address(dst_data(1,2), temp_address, ierror)
273 dst_extent = temp_address - base_address
274
275 ! repeated redist parameters:
276 src_displacements = [0,1,2]
277 dst_displacements = [2,0,1]
278
279 ! connect to explicit shape interface:
280 redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, &
281 num_slice, src_displacements, dst_displacements, config)
282 dst_data = -1.0_dp
283 CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
284 CALL xt_redist_delete(redist_repeat)
285
286 ! connect to assumed shape interface:
287 redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, &
288 src_displacements, dst_displacements, config)
289 dst_data = -1.0_dp
290 CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
291 CALL xt_redist_delete(redist_repeat)
292
293 CALL xt_redist_delete(redist)
294 END SUBROUTINE test_repeated_redist_asym
295
296 SUBROUTINE test_repeated_redist_with_gap(comm, config)
297 INTEGER, INTENT(in) :: comm
298 TYPE(xt_config), INTENT(in) :: config
299
300 ! test with one redist used three times (with two different input data
301 ! displacements -> test of cache) (with default cache size)
302 ! set up data
303 INTEGER, PARAMETER :: num_slice = 3
304 INTEGER, PARAMETER :: src_slice_len = 5
305 TYPE(xt_xmap) :: xmap
306 TYPE(xt_redist) :: redist, redist_repeat
307 INTEGER(mpi_address_kind) :: src_extent, dst_extent
308 INTEGER(mpi_address_kind) :: base_address, temp_address
309 INTEGER(c_int), PARAMETER :: displacements(3) = (/0,2,4/)
310 DOUBLE PRECISION, TARGET :: src_template(5, 3), dst_template(3, 3)
311 INTEGER :: ierror
312
313 xmap = build_odd_selection_xmap(src_slice_len, comm)
314
315 redist = xt_redist_p2p_new(xmap, mpi_double_precision)
316
317 CALL xt_xmap_delete(xmap)
318
319 ! generate redist_repeat
320 CALL mpi_get_address(src_template(1,1), base_address, ierror)
321 CALL mpi_get_address(src_template(1,2), temp_address, ierror)
322 src_extent = temp_address - base_address
323 CALL mpi_get_address(dst_template(1,1), base_address, ierror)
324 CALL mpi_get_address(dst_template(1,2), temp_address, ierror)
325 dst_extent = temp_address - base_address
326
327 redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, &
328 num_slice, displacements, config)
329 CALL xt_redist_delete(redist)
330
331 ! test exchange
332 CALL test_repeated_redist_ds1_with_gap(redist_repeat)
333 ! clean up
334 CALL xt_redist_delete(redist_repeat)
335 END SUBROUTINE test_repeated_redist_with_gap
336
337 SUBROUTINE test_repeated_overlapping_redist(comm, config)
338 INTEGER, INTENT(in) :: comm
339 TYPE(xt_config), INTENT(in) :: config
340
341 ! test with one redist used three times (with two different input data
342 ! displacements -> test of cache) (with default cache size)
343 ! set up data
344 INTEGER, PARAMETER :: npt = 9, selection_len = 6
345 TYPE(xt_xmap) :: xmap
346 TYPE(xt_redist) :: redist, redist_repeat
347 INTEGER(mpi_address_kind) :: src_extent, dst_extent
348 INTEGER(mpi_address_kind) :: base_address, temp_address
349 INTEGER(c_int), PARAMETER :: displacements(2) = (/ 0_c_int, 1_c_int /)
350 INTEGER :: i, j, ierror
351 INTEGER, PARAMETER :: src_pos(npt) = (/ (i, i=1,npt) /), &
352 dst_pos(npt) = (/ (2*i, i = 0, npt-1) /)
353 DOUBLE PRECISION :: src_data(npt), dst_data(npt)
354#if __INTEL_COMPILER >= 1600 && __INTEL_COMPILER <= 1602 || defined __PGI
355 DOUBLE PRECISION :: ref_dst_data(npt)
356#else
357 DOUBLE PRECISION, PARAMETER :: ref_dst_data(npt) &
358 = (/ ((dble(((2-j)*3+i+101)*((abs(j)+j)/abs(j+max(1,j))) &
359 & +(j-1-abs(j-1))/2), &
360 & i=1,3 ),j=2,0,-1) /)
361#endif
362 DOUBLE PRECISION, TARGET :: src_template(2), dst_template(2)
363 INTEGER :: iexch
364 TYPE(xt_request) :: request(2)
365
366 xmap = build_odd_selection_xmap(selection_len, comm)
367
368 redist = xt_redist_p2p_off_new(xmap, src_pos, dst_pos, mpi_double_precision)
369
370 CALL xt_xmap_delete(xmap)
371
372 ! init data
373#if __INTEL_COMPILER >= 1600 && __INTEL_COMPILER <= 1602 || defined __PGI
374 DO j = 2, 0, -1
375 DO i = 1, 3
376 ref_dst_data(i + (2-j)*3) = dble(((2-j)*3+i+101)*((abs(j)+j)/abs(j+1)) &
377 & +(j-1-abs(j-1))/2)
378 END DO
379 END DO
380#endif
381 DO i = 1, npt
382 src_data(i) = 1.0d2 + dble(i)
383 END DO
384
385 DO iexch = 1, 2
386
387 dst_data = -1.0d0
388
389 ! test individual redists
390 IF (iexch == 1) THEN
391 CALL xt_redist_s_exchange(redist, src_data, dst_data)
392 CALL xt_redist_s_exchange(redist, src_data(2:), dst_data(2:))
393 ELSE
394 CALL xt_redist_a_exchange(redist, src_data, dst_data, request(1))
395 CALL xt_redist_a_exchange(redist, src_data(2:), dst_data(2:), request(2))
396 CALL check_wait_request(request(1), filename, __line__)
397 CALL check_wait_request(request(2), filename, __line__)
398 ENDIF
399 ! check individual redists to have desired effect
400 IF (cmp_arrays(dst_data, ref_dst_data)) &
401 CALL test_abort("error in "//exch1name(iexch), filename,__line__)
402 ENDDO
403 dst_data = -1.0d0
404 ! generate redist_repeat
405 CALL mpi_get_address(src_template(1), base_address, ierror)
406 CALL mpi_get_address(src_template(2), temp_address, ierror)
407 src_extent = temp_address - base_address
408 CALL mpi_get_address(dst_template(1), base_address, ierror)
409 CALL mpi_get_address(dst_template(2), temp_address, ierror)
410 dst_extent = temp_address - base_address
411
412 redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, &
413 displacements, config)
414 CALL xt_redist_delete(redist)
415
416 ! test exchange
417 CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
418 ! clean up
419 CALL xt_redist_delete(redist_repeat)
420 END SUBROUTINE test_repeated_overlapping_redist
421
422END PROGRAM test_redist_repeat
423!
424! Local Variables:
425! f90-continuation-indent: 5
426! coding: utf-8
427! indent-tabs-mode: nil
428! show-trailing-whitespace: t
429! require-trailing-newline: t
430! End:
431!
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
void xt_redist_delete(Xt_redist redist)
Definition xt_redist.c:74
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_p2p_off_new(Xt_xmap xmap, const int *src_offsets, const int *dst_offsets, MPI_Datatype datatype)
Xt_redist xt_redist_p2p_new(Xt_xmap xmap, MPI_Datatype datatype)
Xt_redist xt_redist_repeat_new(Xt_redist redist, MPI_Aint src_extent, MPI_Aint dst_extent, int num_repetitions, const int displacements[num_repetitions])
void xt_xmap_delete(Xt_xmap xmap)
Definition xt_xmap.c:86