Yet Another eXchange Tool  DO_NOT_EDIT_HERE
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://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 
49 PROGRAM test_redist_collection
50  USE mpi
51  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
52  USE test_idxlist_utils, ONLY: test_err_count
53  USE yaxt, ONLY: xt_initialize, xt_finalize, &
54  xt_xmap, xt_xmap_delete, xt_xmap_all2all_new, &
55  xt_redist, xt_redist_p2p_new, xt_redist_collection_new, &
56  xt_redist_delete, xt_redist_copy, &
57  xt_redist_s_exchange, &
58  xt_slice_c_loc, xt_idxempty_new, xt_idxlist_delete, &
59  xt_idxlist
60  ! older PGI compilers do not handle generic interface correctly
61 #if defined __PGI && (__PGIC__ < 12 || (__PGIC__ == 12 && __PGIC_MINOR__ <= 10))
62  USE xt_redist_base, ONLY: xt_redist_s_exchange
63 #endif
64  USE test_redist_common, ONLY: build_odd_selection_xmap, check_redist
65  USE iso_c_binding, ONLY: c_loc, c_ptr
66  USE redist_collection_displace, ONLY: test_displacement_variations
67  IMPLICIT NONE
68  CALL init_mpi
69  CALL xt_initialize(mpi_comm_world)
70 
71  CALL simple_test
72  CALL simple_test2
73  CALL test_empty_redist
74  CALL test_repeated_redist(-1)
75  CALL test_repeated_redist(0)
76  CALL test_displacement_variations
77 
78  IF (test_err_count() /= 0) &
79  CALL test_abort("non-zero error count!", &
80  __file__, &
81  __line__)
82  CALL xt_finalize
83  CALL finish_mpi
84 CONTAINS
85  SUBROUTINE simple_test
86  ! general test with one redist
87  ! set up data
88  TYPE(xt_xmap) :: xmap
89  TYPE(xt_redist) :: redist, redist_coll, redist_copy
90  INTEGER, PARAMETER :: src_slice_len = 5, dst_slice_len = 3
91  DOUBLE PRECISION, PARAMETER :: &
92  ref_dst_data(dst_slice_len) = (/ 1.0d0, 3.0d0, 5.0d0 /), &
93  src_data(src_slice_len) = (/ 1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0 /)
94  DOUBLE PRECISION :: dst_data(dst_slice_len)
95 
96 
97  xmap = build_odd_selection_xmap(src_slice_len)
98 
99  redist = xt_redist_p2p_new(xmap, mpi_double_precision)
100  CALL xt_xmap_delete(xmap)
101  redist_copy = xt_redist_copy(redist)
102  CALL xt_redist_delete(redist)
103  redist = redist_copy
104 
105  ! generate redist_collection
106  redist_coll = xt_redist_collection_new((/ redist /), 1, -1, mpi_comm_world)
107 
108  CALL xt_redist_delete(redist)
109 
110  ! test exchange
111  CALL check_redist(redist_coll, src_data, dst_data, ref_dst_data)
112 
113  ! clean up
114  CALL xt_redist_delete(redist_coll)
115  END SUBROUTINE simple_test
116 
117  SUBROUTINE simple_test2
118  ! general test with one redist
119  ! set up data
120  TYPE(xt_xmap) :: xmap
121  TYPE(xt_redist) :: redist_coll, redist_copy, &
122  redist_components(2)
123  INTEGER, PARAMETER :: src_slice_len = 5, dst_slice_len = 3
124  TYPE src_data_collection
125  DOUBLE PRECISION :: dp(src_slice_len)
126  LOGICAL :: l(src_slice_len)
127  END TYPE src_data_collection
128  TYPE dst_data_collection
129  DOUBLE PRECISION :: dp(dst_slice_len)
130  LOGICAL :: l(dst_slice_len)
131  END TYPE dst_data_collection
132  TYPE(src_data_collection), SAVE, TARGET :: src_data = src_data_collection(&
133  (/ 1.0d0, 2.0d0, 3.0d0, 4.0d0, 5.0d0 /), &
134  (/ .true., .false., .true., .false., .true. /))
135  TYPE(dst_data_collection), PARAMETER :: &
136  ref_dst_data = dst_data_collection((/ 1.0d0, 3.0d0, 5.0d0 /), &
137  (/ .true., .true., .true. /))
138  TYPE(dst_data_collection), TARGET :: dst_data
139  TYPE(c_ptr) :: src_data_p(2), dst_data_p(2)
140 
141  xmap = build_odd_selection_xmap(src_slice_len)
142 
143  redist_components(1) = xt_redist_p2p_new(xmap, mpi_double_precision)
144  redist_components(2) = xt_redist_p2p_new(xmap, mpi_logical)
145  CALL xt_xmap_delete(xmap)
146 
147  ! generate redist_collection
148  redist_coll = xt_redist_collection_new(redist_components, mpi_comm_world)
149  CALL xt_redist_delete(redist_components)
150  redist_copy = xt_redist_copy(redist_coll)
151  CALL xt_redist_delete(redist_coll)
152  redist_coll = redist_copy
153 
154  ! test exchange
155  ! GNU Fortran versions up to 4.8 cannot call c_loc for type components,
156  ! instant ICE, and some compilers won't create c_ptr's to LOGICALs
157 #if !defined(__GNUC__) || __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ > 8)
158  src_data_p(1) = c_loc(src_data%dp)
159 #else
160  CALL xt_slice_c_loc(src_data%dp, src_data_p(1))
161 #endif
162 #if !defined HAVE_FC_LOGICAL_INTEROP || !defined(__GNUC__) || __GNUC__ > 4 \
163  || (__gnuc__ == 4 && __gnuc_minor__ > 8)
164  CALL xt_slice_c_loc(src_data%l, src_data_p(2))
165 #else
166  src_data_p(2) = c_loc(src_data%l)
167 #endif
168  dst_data%dp = -1.0d0
169  dst_data%l = .false.
170 #if !defined(__GNUC__) || __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ > 8)
171  dst_data_p(1) = c_loc(dst_data%dp)
172 #else
173  CALL xt_slice_c_loc(dst_data%dp, dst_data_p(1))
174 #endif
175 #if !defined HAVE_FC_LOGICAL_INTEROP || !defined(__GNUC__) || __GNUC__ > 4 \
176  || (__gnuc__ == 4 && __gnuc_minor__ > 8)
177  CALL xt_slice_c_loc(dst_data%l, dst_data_p(2))
178 #else
179  dst_data_p(2) = c_loc(dst_data%l)
180 #endif
181  CALL xt_redist_s_exchange(redist_coll, src_data_p, dst_data_p)
182  IF (any(dst_data%l .NEQV. ref_dst_data%l)) &
183  CALL test_abort("error in xt_redist_s_exchange", &
184  __file__, &
185  __line__)
186  IF (any(dst_data%dp /= ref_dst_data%dp)) &
187  CALL test_abort("error in xt_redist_s_exchange", &
188  __file__, &
189  __line__)
190 
191  ! clean up
192  CALL xt_redist_delete(redist_coll)
193  END SUBROUTINE simple_test2
194 
195  SUBROUTINE test_empty_redist
196  ! general test with empty redist
197  ! set up data
198  TYPE(xt_idxlist) :: src_idxlist, dst_idxlist
199  TYPE(xt_xmap) :: xmap
200  TYPE(xt_redist) :: redist, redist_coll, redist_copy
201 
202 
203  src_idxlist = xt_idxempty_new()
204  dst_idxlist = xt_idxempty_new()
205 
206  xmap = xt_xmap_all2all_new(src_idxlist, dst_idxlist, mpi_comm_world)
207 
208  CALL xt_idxlist_delete(src_idxlist)
209  CALL xt_idxlist_delete(dst_idxlist)
210 
211  redist = xt_redist_p2p_new(xmap, mpi_double_precision)
212  CALL xt_xmap_delete(xmap)
213  redist_copy = xt_redist_copy(redist)
214  CALL xt_redist_delete(redist)
215  redist = redist_copy
216 
217  ! generate redist_collection
218  redist_coll = xt_redist_collection_new((/ redist /), 1, -1, mpi_comm_world)
219 
220  CALL xt_redist_delete(redist)
221 
222  ! clean up
223  CALL xt_redist_delete(redist_coll)
224  END SUBROUTINE test_empty_redist
225 
226  SUBROUTINE test_repeated_redist_ds1(redist_coll)
227  TYPE(xt_redist), INTENT(in) :: redist_coll
228  INTEGER :: i, j
229  DOUBLE PRECISION, SAVE, TARGET :: src_data(5, 3) = reshape((/&
230  (dble(i), i = 1, 15)/), (/ 5, 3 /))
231  DOUBLE PRECISION, PARAMETER :: ref_dst_data(3, 3) &
232  = reshape((/ ((dble(i + j), i = 1,5,2), j = 0,10,5) /), (/ 3, 3 /))
233  DOUBLE PRECISION, TARGET :: dst_data(3, 3)
234  TYPE(c_ptr) :: src_data_p(3), dst_data_p(3)
235  dst_data = -1.0d0
236  DO i = 1, 3
237  CALL xt_slice_c_loc(src_data(:, i), src_data_p(i))
238  CALL xt_slice_c_loc(dst_data(:, i), dst_data_p(i))
239  END DO
240  CALL xt_redist_s_exchange(redist_coll, 3, src_data_p, dst_data_p)
241 
242  IF (any(ref_dst_data /= dst_data)) &
243  CALL test_abort("error in xt_redist_s_exchange", &
244  __file__, &
245  __line__)
246  END SUBROUTINE test_repeated_redist_ds1
247 
248  SUBROUTINE test_repeated_redist_ds2(redist_coll)
249  TYPE(xt_redist), INTENT(in) :: redist_coll
250  INTEGER :: i, j
251  DOUBLE PRECISION, SAVE, TARGET :: src_data(5, 3) = reshape((/&
252  (dble(i), i = 1, 15)/), (/ 5, 3 /))
253  DOUBLE PRECISION, PARAMETER :: ref_dst_data(3, 3) &
254  = reshape((/ ((dble(i + j), i = 1,5,2), j = 0,10,5) /), (/ 3, 3 /))
255  DOUBLE PRECISION, TARGET :: dst_data(3, 3)
256  TYPE(c_ptr) :: src_data_p(3), dst_data_p(3)
257  dst_data = -1.0d0
258  CALL xt_slice_c_loc(src_data(:, 2), src_data_p(1))
259  CALL xt_slice_c_loc(src_data(:, 1), src_data_p(2))
260  CALL xt_slice_c_loc(src_data(:, 3), src_data_p(3))
261  CALL xt_slice_c_loc(dst_data(:, 2), dst_data_p(1))
262  CALL xt_slice_c_loc(dst_data(:, 1), dst_data_p(2))
263  CALL xt_slice_c_loc(dst_data(:, 3), dst_data_p(3))
264  CALL xt_redist_s_exchange(redist_coll, 3, src_data_p, dst_data_p)
265 
266  IF (any(ref_dst_data /= dst_data)) &
267  CALL test_abort("error in xt_redist_s_exchange", &
268  __file__, &
269  __line__)
270  END SUBROUTINE test_repeated_redist_ds2
271 
272  SUBROUTINE test_repeated_redist(cache_size)
273  INTEGER, INTENT(in) :: cache_size
274  ! test with one redist used three times (with two different input data
275  ! displacements -> test of cache) (with default cache size)
276  ! set up data
277  INTEGER, PARAMETER :: num_slice = 3
278  INTEGER, PARAMETER :: src_slice_len = 5
279  TYPE(xt_xmap) :: xmap
280  TYPE(xt_redist) :: redists(num_slice), redist_coll, redist_coll_copy
281 
282  xmap = build_odd_selection_xmap(src_slice_len)
283 
284  redists = xt_redist_p2p_new(xmap, mpi_double_precision)
285 
286  CALL xt_xmap_delete(xmap)
287 
288  ! generate redist_collection
289 
290  redist_coll = xt_redist_collection_new(redists, 3, cache_size, &
291  mpi_comm_world)
292 
293  CALL xt_redist_delete(redists(1))
294 
295  ! test exchange
296  CALL test_repeated_redist_ds1(redist_coll)
297  ! test exchange with changed displacements
298  CALL test_repeated_redist_ds2(redist_coll)
299  ! test exchange with original displacements
300  CALL test_repeated_redist_ds1(redist_coll)
301 
302  ! and the copy
303  redist_coll_copy = xt_redist_copy(redist_coll)
304  CALL xt_redist_delete(redist_coll)
305  CALL test_repeated_redist_ds1(redist_coll_copy)
306  ! test exchange with changed displacements
307  CALL test_repeated_redist_ds2(redist_coll_copy)
308  ! test exchange with original displacements
309  CALL test_repeated_redist_ds1(redist_coll_copy)
310 
311  ! clean up
312  CALL xt_redist_delete(redist_coll_copy)
313  END SUBROUTINE test_repeated_redist
314 
315 END PROGRAM test_redist_collection
316 !
317 ! Local Variables:
318 ! f90-continuation-indent: 5
319 ! coding: utf-8
320 ! indent-tabs-mode: nil
321 ! show-trailing-whitespace: t
322 ! require-trailing-newline: t
323 ! End:
324 !
Generated by   doxygen 1.8.13