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