Yet Another eXchange Tool  DO_NOT_EDIT_HERE
test_redist_repeat_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 PROGRAM test_redist_repeat
49  USE mpi
50  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
51  USE test_idxlist_utils, ONLY: test_err_count
52  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_xmap, xt_xmap_delete, &
53  xt_redist, xt_redist_p2p_new, xt_redist_p2p_off_new, &
54  xt_redist_repeat_new, &
55  xt_redist_delete, xt_redist_s_exchange1
56  USE test_redist_common, ONLY: build_odd_selection_xmap, check_redist
57  USE iso_c_binding, ONLY: c_loc, c_int
58  IMPLICIT NONE
59  CALL init_mpi
60  CALL xt_initialize(mpi_comm_world)
61 
62  CALL simple_test
63  CALL test_repeated_redist
64  CALL test_repeated_redist_with_gap
65  CALL test_repeated_overlapping_redist
66  CALL test_repeated_redist_asym
67 
68  IF (test_err_count() /= 0) &
69  CALL test_abort("non-zero error count!", &
70  __file__, &
71  __line__)
72  CALL xt_finalize
73  CALL finish_mpi
74 CONTAINS
75  SUBROUTINE simple_test
76  ! general test with one redist
77  ! set up data
78  TYPE(xt_xmap) :: xmap
79  TYPE(xt_redist) :: redist, redist_repeat
80  INTEGER, PARAMETER :: src_slice_len = 5, dst_slice_len = 3
81  DOUBLE PRECISION, PARAMETER :: ref_dst_data(dst_slice_len) &
82  = (/ 1.0d0, 3.0d0, 5.0d0 /), &
83  src_data(src_slice_len) = (/ 1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0 /)
84  DOUBLE PRECISION :: dst_data(dst_slice_len)
85  INTEGER(mpi_address_kind) :: src_extent, dst_extent
86  INTEGER(mpi_address_kind) :: base_address, temp_address
87  INTEGER(c_int) :: displacements(1) = 0
88  INTEGER :: ierror
89 
90  xmap = build_odd_selection_xmap(src_slice_len)
91 
92  redist = xt_redist_p2p_new(xmap, mpi_double_precision)
93 
94  CALL xt_xmap_delete(xmap)
95 
96  CALL mpi_get_address(src_data(1), base_address, ierror)
97  CALL mpi_get_address(src_data(2), temp_address, ierror)
98  src_extent = (temp_address - base_address) * src_slice_len
99  CALL mpi_get_address(dst_data(1), base_address, ierror)
100  CALL mpi_get_address(dst_data(2), temp_address, ierror)
101  dst_extent = (temp_address - base_address) * dst_slice_len
102 
103  ! generate redist_repeat
104  redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, 1, &
105  displacements)
106 
107  CALL xt_redist_delete(redist)
108 
109  ! test exchange
110  CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
111 
112  ! clean up
113  CALL xt_redist_delete(redist_repeat)
114  END SUBROUTINE simple_test
115 
116  SUBROUTINE test_repeated_redist_ds1(redist_repeat)
117  TYPE(xt_redist), INTENT(in) :: redist_repeat
118  INTEGER :: i, j
119  DOUBLE PRECISION, PARAMETER :: src_data(5, 3) = reshape((/&
120  (dble(i), i = 1, 15)/), (/ 5, 3 /))
121  DOUBLE PRECISION, PARAMETER :: ref_dst_data(3, 3) &
122  = reshape((/ ((dble(i + j), i = 1,5,2), j = 0,10,5) /), (/ 3, 3 /))
123  DOUBLE PRECISION :: dst_data(3, 3)
124 
125  CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
126  END SUBROUTINE test_repeated_redist_ds1
127 
128  SUBROUTINE test_repeated_redist_ds1_with_gap(redist_repeat)
129  TYPE(xt_redist), INTENT(in) :: redist_repeat
130  INTEGER :: i, j
131  DOUBLE PRECISION, PARAMETER :: src_data(5, 5) = reshape((/&
132  (dble(i), i = 1, 25)/), (/ 5, 5 /))
133  DOUBLE PRECISION :: dst_data(3, 5)
134 #ifndef __PGI
135  DOUBLE PRECISION, PARAMETER :: ref_dst_data(3, 5) &
136  = reshape((/ ((dble((i + j)*mod(j+1,2)-mod(j,2)), i = 1,5,2), &
137  j = 0,20,5) /), (/ 3, 5 /))
138 #else
139  DOUBLE PRECISION :: ref_dst_data(3, 5)
140  ref_dst_data &
141  = reshape((/ ((dble((i + j)*mod(j+1,2)-mod(j,2)), i = 1,5,2), &
142  j = 0,20,5) /), (/ 3, 5 /))
143 #endif
144  CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
145  END SUBROUTINE test_repeated_redist_ds1_with_gap
146 
147  SUBROUTINE test_repeated_redist_ds2(redist_repeat)
148  TYPE(xt_redist), INTENT(in) :: redist_repeat
149  INTEGER :: i, j
150  DOUBLE PRECISION, PARAMETER :: src_data(5, 3) = reshape((/&
151  (dble(i), i = 20, 34)/), (/ 5, 3 /))
152  DOUBLE PRECISION, PARAMETER :: ref_dst_data(3, 3) &
153  = reshape((/ ((dble(i + j), i = 1,5,2), j = 19,33,5) /), (/ 3, 3 /))
154  DOUBLE PRECISION :: dst_data(3, 3)
155 
156  CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
157  END SUBROUTINE test_repeated_redist_ds2
158 
159  SUBROUTINE test_repeated_redist
160  ! test with one redist used three times (with two different input data
161  ! displacements -> test of cache) (with default cache size)
162  ! set up data
163  INTEGER, PARAMETER :: num_slice = 3
164  INTEGER, PARAMETER :: src_slice_len = 5
165  TYPE(xt_xmap) :: xmap
166  TYPE(xt_redist) :: redist, redist_repeat
167  INTEGER(mpi_address_kind) :: src_extent, dst_extent
168  INTEGER(mpi_address_kind) :: base_address, temp_address
169  INTEGER(c_int) :: displacements(3)
170  DOUBLE PRECISION, TARGET :: src_template(5, 3), dst_template(3, 3)
171  INTEGER :: ierror
172 
173  xmap = build_odd_selection_xmap(src_slice_len)
174 
175  redist = xt_redist_p2p_new(xmap, mpi_double_precision)
176 
177  CALL xt_xmap_delete(xmap)
178 
179  ! generate redist_repeat
180  CALL mpi_get_address(src_template(1,1), base_address, ierror)
181  CALL mpi_get_address(src_template(1,2), temp_address, ierror)
182  src_extent = temp_address - base_address
183  CALL mpi_get_address(dst_template(1,1), base_address, ierror)
184  CALL mpi_get_address(dst_template(1,2), temp_address, ierror)
185  dst_extent = temp_address - base_address
186  displacements = (/0,1,2/)
187 
188  redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, &
189  num_slice, displacements)
190  CALL xt_redist_delete(redist)
191 
192  ! test exchange
193  CALL test_repeated_redist_ds1(redist_repeat)
194  ! test exchange
195  CALL test_repeated_redist_ds2(redist_repeat)
196  ! clean up
197  CALL xt_redist_delete(redist_repeat)
198  END SUBROUTINE test_repeated_redist
199 
200  SUBROUTINE test_repeated_redist_asym
201  ! test asymmetric variant of redist_repeat
202 
203  INTEGER, PARAMETER :: num_slice = 3
204  INTEGER, PARAMETER :: src_slice_len = 5
205  TYPE(xt_xmap) :: xmap
206  TYPE(xt_redist) :: redist, redist_repeat
207  INTEGER(mpi_address_kind) :: src_extent, dst_extent
208  INTEGER(mpi_address_kind) :: base_address, temp_address
209  INTEGER(c_int) :: src_displacements(3), dst_displacements(3)
210  DOUBLE PRECISION, TARGET :: src_data(5, 3), dst_data(3, 3), ref_dst_data(3, 3)
211  INTEGER, PARAMETER :: dp = kind(src_data)
212  INTEGER :: i, ierror
213 
214  ! xmap: [1,2,3,4,5] -> [1,3,5]
215  xmap = build_odd_selection_xmap(src_slice_len)
216 
217  redist = xt_redist_p2p_new(xmap, mpi_double_precision)
218 
219  CALL xt_xmap_delete(xmap)
220 
221  ! generate redist_repeat:
222  CALL mpi_get_address(src_data(1,1), base_address, ierror)
223  CALL mpi_get_address(src_data(1,2), temp_address, ierror)
224  src_extent = temp_address - base_address
225  CALL mpi_get_address(dst_data(1,1), base_address, ierror)
226  CALL mpi_get_address(dst_data(1,2), temp_address, ierror)
227  dst_extent = temp_address - base_address
228 
229  ! repeated redist parameters:
230  src_displacements = [0,1,2]
231  dst_displacements = [2,0,1]
232 
233  ! test data:
234  src_data = reshape( [(i, i = 1, 15)]*1.0_dp, [5,3] )
235  ref_dst_data = reshape( [6,8,10, 11,13,15, 1,3,5 ]*1.0_dp, [3,3] )
236 
237  ! connect to explicit shape interface:
238  redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, &
239  num_slice, src_displacements, dst_displacements)
240  dst_data = -1.0_dp
241  CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
242  CALL xt_redist_delete(redist_repeat)
243 
244  ! connect to assumed shape interface:
245  redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, &
246  src_displacements, dst_displacements)
247  dst_data = -1.0_dp
248  CALL check_redist(redist_repeat, src_data, dst_data, ref_dst_data)
249  CALL xt_redist_delete(redist_repeat)
250 
251  CALL xt_redist_delete(redist)
252  END SUBROUTINE test_repeated_redist_asym
253 
254  SUBROUTINE test_repeated_redist_with_gap
255  ! test with one redist used three times (with two different input data
256  ! displacements -> test of cache) (with default cache size)
257  ! set up data
258  INTEGER, PARAMETER :: num_slice = 3
259  INTEGER, PARAMETER :: src_slice_len = 5
260  TYPE(xt_xmap) :: xmap
261  TYPE(xt_redist) :: redist, redist_repeat
262  INTEGER(mpi_address_kind) :: src_extent, dst_extent
263  INTEGER(mpi_address_kind) :: base_address, temp_address
264  INTEGER(c_int), PARAMETER :: displacements(3) = (/0,2,4/)
265  DOUBLE PRECISION, TARGET :: src_template(5, 3), dst_template(3, 3)
266  INTEGER :: ierror
267 
268  xmap = build_odd_selection_xmap(src_slice_len)
269 
270  redist = xt_redist_p2p_new(xmap, mpi_double_precision)
271 
272  CALL xt_xmap_delete(xmap)
273 
274  ! generate redist_repeat
275  CALL mpi_get_address(src_template(1,1), base_address, ierror)
276  CALL mpi_get_address(src_template(1,2), temp_address, ierror)
277  src_extent = temp_address - base_address
278  CALL mpi_get_address(dst_template(1,1), base_address, ierror)
279  CALL mpi_get_address(dst_template(1,2), temp_address, ierror)
280  dst_extent = temp_address - base_address
281 
282  redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, &
283  num_slice, displacements)
284  CALL xt_redist_delete(redist)
285 
286  ! test exchange
287  CALL test_repeated_redist_ds1_with_gap(redist_repeat)
288  ! clean up
289  CALL xt_redist_delete(redist_repeat)
290  END SUBROUTINE test_repeated_redist_with_gap
291 
292  SUBROUTINE test_repeated_overlapping_redist
293  ! test with one redist used three times (with two different input data
294  ! displacements -> test of cache) (with default cache size)
295  ! set up data
296  INTEGER, PARAMETER :: npt = 9, selection_len = 6
297  TYPE(xt_xmap) :: xmap
298  TYPE(xt_redist) :: redist, redist_repeat
299  INTEGER(mpi_address_kind) :: src_extent, dst_extent
300  INTEGER(mpi_address_kind) :: base_address, temp_address
301  INTEGER(c_int), PARAMETER :: displacements(2) = (/ 0, 1 /)
302  INTEGER :: i, j, ierror
303  INTEGER, PARAMETER :: src_pos(npt) = (/ (i, i=1,npt) /), &
304  dst_pos(npt) = (/ (2*i, i = 0, npt-1) /)
305  DOUBLE PRECISION, TARGET :: src_data(npt), dst_data(npt)
306 #if __INTEL_COMPILER >= 1600 && __INTEL_COMPILER <= 1602 || defined __PGI
307  DOUBLE PRECISION :: ref_dst_data(npt)
308 #else
309  DOUBLE PRECISION, PARAMETER :: ref_dst_data(npt) &
310  = (/ ((dble(((2-j)*3+i+101)*((abs(j)+j)/abs(j+1)) &
311  & +(j-1-abs(j-1))/2), &
312  & i=1,3 ),j=2,0,-1) /)
313 #endif
314  DOUBLE PRECISION, TARGET :: src_template(2), dst_template(2)
315 
316  xmap = build_odd_selection_xmap(selection_len)
317 
318  redist = xt_redist_p2p_off_new(xmap, src_pos, dst_pos, mpi_double_precision)
319 
320  CALL xt_xmap_delete(xmap)
321 
322  ! init data
323 #if __INTEL_COMPILER >= 1600 && __INTEL_COMPILER <= 1602 || defined __PGI
324  DO j = 2, 0, -1
325  DO i = 1, 3
326  ref_dst_data(i + (2-j)*3) = dble(((2-j)*3+i+101)*((abs(j)+j)/abs(j+1)) &
327  & +(j-1-abs(j-1))/2)
328  END DO
329  END DO
330 #endif
331  DO i = 1, npt
332  src_data(i) = 1.0d2 + dble(i)
333  END DO
334  dst_data = -1.0d0
335 
336  ! test individual redists
337  CALL redist_dbl(redist, src_data, dst_data)
338  CALL redist_dbl(redist, src_data(2:), dst_data(2:))
339  ! check individual redists to have desired effect
340  IF (any(dst_data /= ref_dst_data)) &
341  CALL test_abort("error in xt_redist_s_exchange1", &
342  __file__, &
343  __line__)
344  dst_data = -1.0d0
345  ! generate redist_repeat
346  CALL mpi_get_address(src_template(1), base_address, ierror)
347  CALL mpi_get_address(src_template(2), temp_address, ierror)
348  src_extent = temp_address - base_address
349  CALL mpi_get_address(dst_template(1), base_address, ierror)
350  CALL mpi_get_address(dst_template(2), temp_address, ierror)
351  dst_extent = temp_address - base_address
352 
353  redist_repeat = xt_redist_repeat_new(redist, src_extent, dst_extent, &
354  displacements)
355  CALL xt_redist_delete(redist)
356 
357  ! test exchange
358  CALL check_redist(redist_repeat, src_data, SIZE(dst_data), &
359  dst_data, ref_dst_data)
360  ! clean up
361  CALL xt_redist_delete(redist_repeat)
362  END SUBROUTINE test_repeated_overlapping_redist
363 
364  ! work-around for F2003 restriction on slice c_loc
365  SUBROUTINE redist_dbl(redist, src_data, dst_data)
366  TYPE(xt_redist), INTENT(in) :: redist
367  DOUBLE PRECISION, TARGET, INTENT(in) :: src_data(*)
368  DOUBLE PRECISION, TARGET, INTENT(inout) :: dst_data(*)
369  CALL xt_redist_s_exchange1(redist, c_loc(src_data), c_loc(dst_data))
370  END SUBROUTINE redist_dbl
371 
372 END PROGRAM test_redist_repeat
373 !
374 ! Local Variables:
375 ! f90-continuation-indent: 5
376 ! coding: utf-8
377 ! indent-tabs-mode: nil
378 ! show-trailing-whitespace: t
379 ! require-trailing-newline: t
380 ! End:
381 !
Generated by   doxygen 1.8.13