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