Yet Another eXchange Tool  DO_NOT_EDIT_HERE
test_idxvec_f.f90
1 
12 
13 !
14 ! Keywords:
15 ! Maintainer: Jörg Behrens <behrens@dkrz.de>
16 ! Moritz Hanke <hanke@dkrz.de>
17 ! Thomas Jahns <jahns@dkrz.de>
18 ! URL: https://doc.redmine.dkrz.de/yaxt/html/
19 !
20 ! Redistribution and use in source and binary forms, with or without
21 ! modification, are permitted provided that the following conditions are
22 ! met:
23 !
24 ! Redistributions of source code must retain the above copyright notice,
25 ! this list of conditions and the following disclaimer.
26 !
27 ! Redistributions in binary form must reproduce the above copyright
28 ! notice, this list of conditions and the following disclaimer in the
29 ! documentation and/or other materials provided with the distribution.
30 !
31 ! Neither the name of the DKRZ GmbH nor the names of its contributors
32 ! may be used to endorse or promote products derived from this software
33 ! without specific prior written permission.
34 !
35 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
36 ! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
37 ! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
38 ! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
39 ! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
40 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
41 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
42 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
43 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
44 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
45 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
46 !
47 PROGRAM test_idxvec
48  USE mpi
49  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_idxlist, xt_idxvec_new, &
50  xt_idxvec_from_stripes_new, &
51  xt_int_kind, xt_stripe, xt_idxlist_get_intersection, &
52  xt_idxlist_get_index_stripes, xt_idxlist_delete, &
53  xt_idxlist_get_positions_of_indices, &
54  xt_idxlist_get_index_at_position, xt_idxlist_get_indices_at_positions, &
55  xt_idxlist_get_position_of_index, xt_idxlist_get_position_of_index_off, &
56  xt_bounds, xt_idxlist_get_bounding_box, xt_idxlist_copy
57  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
58  USE test_idxlist_utils, ONLY: check_idxlist, test_err_count, check_stripes, &
59  check_offsets, idxlist_pack_unpack_copy
60  IMPLICIT NONE
61  INTEGER, PARAMETER :: xi = xt_int_kind
62  INTEGER(xt_int_kind), PARAMETER :: index_vector(7) &
63  = (/ 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, 7_xi /)
64 
65 
66  CALL init_mpi
67  CALL xt_initialize(mpi_comm_world)
68 
69  CALL test_idxvec_pack_unpack
70  CALL test_copying
71  CALL test_repeated_equal_indices
72  CALL test_positions
73  CALL test_intersection_surjective
74  CALL test_intersection_partial
75  CALL test_intersection_inverse_partial
76  CALL test_intersection_unsort_partial
77  CALL test_intersection_unsort_inverse_partial
78  CALL test_stripes1
79  CALL test_stripes2
80  CALL test_stripes3
81  CALL test_stripes4
82  CALL test_stripes5
83  CALL test_stripes6
84  CALL test_stripes7
85  CALL test_get_indices_at_positions1
86  CALL test_get_indices_at_positions2
87  CALL test_get_indices_at_positions3
88  CALL test_get_positions_of_indices
89  CALL test_bounding_box1
90  CALL test_bounding_box2
91  CALL test_bounding_box3
92 
93  IF (test_err_count() /= 0) &
94  CALL test_abort("non-zero error count!", &
95  __file__, &
96  __line__)
97  CALL xt_finalize
98  CALL finish_mpi
99 CONTAINS
100  SUBROUTINE test_idxvec_pack_unpack
101  TYPE(xt_idxlist) :: idxvector, idxvector_copy, intersection
102  TYPE(xt_stripe), PARAMETER :: ref_stripes(1) = (/ xt_stripe(1, 1, 7) /)
103  CALL setup_idxvec(idxvector, index_vector)
104 
105  idxvector_copy = idxlist_pack_unpack_copy(idxvector)
106 
107  CALL check_idxlist(idxvector_copy, index_vector)
108 
109  intersection = xt_idxlist_get_intersection(idxvector, idxvector_copy)
110 
111  CALL check_idxlist(intersection, index_vector)
112 
113  CALL compare_stripes(idxvector, ref_stripes)
114 
115  CALL xt_idxlist_delete(idxvector)
116  CALL xt_idxlist_delete(idxvector_copy)
117  CALL xt_idxlist_delete(intersection)
118 
119  END SUBROUTINE test_idxvec_pack_unpack
120 
121  SUBROUTINE test_copying
122  TYPE(xt_idxlist) :: idxvector, idxvector_copy
123  CALL setup_idxvec(idxvector, index_vector)
124  idxvector_copy = xt_idxlist_copy(idxvector)
125  CALL check_idxlist(idxvector_copy, index_vector)
126  CALL xt_idxlist_delete(idxvector)
127  CALL xt_idxlist_delete(idxvector_copy)
128  END SUBROUTINE test_copying
129 
130  SUBROUTINE test_repeated_equal_indices
131  INTEGER(xt_int_kind), PARAMETER :: index_vector(8) &
132  = (/ 1_xi, 2_xi, 3_xi, 7_xi, 5_xi, 6_xi, 7_xi, 7_xi /)
133  TYPE(xt_idxlist) :: idxvector
134  CALL setup_idxvec(idxvector, index_vector)
135  CALL xt_idxlist_delete(idxvector)
136  END SUBROUTINE test_repeated_equal_indices
137 
138  SUBROUTINE test_positions
139  LOGICAL, PARAMETER :: single_match_only = .true.
140  INTEGER(xt_int_kind), PARAMETER :: index_vector(20) &
141  = (/ 10_xi, 15_xi, 14_xi, 13_xi, 12_xi, &
142  & 15_xi, 10_xi, 11_xi, 12_xi, 13_xi, &
143  & 23_xi, 18_xi, 19_xi, 20_xi, 21_xi, &
144  & 31_xi, 26_xi, 27_xi, 28_xi, 29_xi /), &
145  intersection_vector(13) &
146  = (/ 12_xi, 12_xi, 13_xi, 13_xi, 14_xi, &
147  & 15_xi, 15_xi, 20_xi, 21_xi, 23_xi, &
148  & 28_xi, 29_xi, 31_xi /)
149  INTEGER :: intersection_pos(size(intersection_vector))
150  INTEGER, PARAMETER :: ref_intersection_pos(size(intersection_vector)) &
151  = (/ 4, 8, 3, 9, 2, 1, 5, 13, 14, 10, 18, 19, 15 /)
152  TYPE(xt_idxlist) :: idxvector
153  INTEGER :: notfound
154  CALL setup_idxvec(idxvector, index_vector)
155  notfound = xt_idxlist_get_positions_of_indices(idxvector, &
156  intersection_vector, intersection_pos, single_match_only)
157  IF (notfound /= 0) &
158  CALL test_abort('expected indices not found!', &
159  __file__, &
160  __line__)
161  CALL check_offsets(intersection_pos, ref_intersection_pos)
162  CALL xt_idxlist_delete(idxvector)
163  END SUBROUTINE test_positions
164 
165  SUBROUTINE test_intersection(index_vector_a, index_vector_b, &
166  ref_intersection_indices)
167  INTEGER(xt_int_kind), INTENT(in) :: index_vector_a(:), index_vector_b(:), &
168  ref_intersection_indices(:)
169  ! note: instead of declaring this as the move intuitive idxvector(2),
170  ! two distinct variables are used to remain compatible with NAG 5.2
171  TYPE(xt_idxlist) :: idxvector1, idxvector2, intersection
172  CALL setup_idxvec(idxvector1, index_vector_a)
173  CALL setup_idxvec(idxvector2, index_vector_b)
174  intersection = xt_idxlist_get_intersection(idxvector1, idxvector2)
175  CALL check_idxlist(intersection, ref_intersection_indices)
176  CALL xt_idxlist_delete(intersection)
177  CALL xt_idxlist_delete(idxvector2)
178  CALL xt_idxlist_delete(idxvector1)
179  END SUBROUTINE test_intersection
180 
181  SUBROUTINE test_intersection_surjective
182  INTEGER(xt_int_kind), PARAMETER :: index_vector(3, 2) &
183  = reshape((/ 1_xi, 2_xi, 3_xi, 1_xi, 2_xi, 3_xi /), &
184  & shape(index_vector)), &
185  ref_intersection_indices(3) = (/ 1_xi, 2_xi, 3_xi /)
186  CALL test_intersection(index_vector(:, 1), index_vector(:, 2), &
187  ref_intersection_indices)
188  END SUBROUTINE test_intersection_surjective
189 
190  SUBROUTINE test_intersection_partial
191  INTEGER(xt_int_kind), PARAMETER :: index_vector(3, 2) &
192  = reshape((/ 1_xi, 2_xi, 3_xi, 2_xi, 3_xi, 4_xi /), &
193  & shape(index_vector)), &
194  ref_intersection_indices(2) = (/ 2_xi, 3_xi /)
195  CALL test_intersection(index_vector(:, 1), index_vector(:, 2), &
196  ref_intersection_indices)
197  END SUBROUTINE test_intersection_partial
198 
199  SUBROUTINE test_intersection_inverse_partial
200  INTEGER(xt_int_kind), PARAMETER :: index_vector(3, 2) &
201  = reshape((/ 2_xi, 3_xi, 4_xi, 1_xi, 2_xi, 3_xi /), &
202  & shape(index_vector)), &
203  ref_intersection_indices(2) = (/ 2_xi, 3_xi /)
204  CALL test_intersection(index_vector(:, 1), index_vector(:, 2), &
205  ref_intersection_indices)
206  END SUBROUTINE test_intersection_inverse_partial
207 
208  SUBROUTINE test_intersection_unsort_partial
209  INTEGER(xt_int_kind), PARAMETER :: index_vector(3, 2) &
210  = reshape((/ 4_xi, 2_xi, 3_xi, 3_xi, 1_xi, 2_xi /), &
211  & shape(index_vector)), &
212  ref_intersection_indices(2) = (/ 2_xi, 3_xi /)
213  CALL test_intersection(index_vector(:, 1), index_vector(:, 2), &
214  ref_intersection_indices)
215  END SUBROUTINE test_intersection_unsort_partial
216 
217  SUBROUTINE test_intersection_unsort_inverse_partial
218  INTEGER(xt_int_kind), PARAMETER :: index_vector(3, 2) &
219  = reshape((/ 3_xi, 1_xi, 2_xi, 4_xi, 2_xi, 3_xi /), &
220  & shape(index_vector)), &
221  ref_intersection_indices(2) = (/ 2_xi, 3_xi /)
222  CALL test_intersection(index_vector(:, 1), index_vector(:, 2), &
223  ref_intersection_indices)
224  END SUBROUTINE test_intersection_unsort_inverse_partial
225 
226  SUBROUTINE test_idxvec_from_stripes(stripes, ref_indices)
227  TYPE(xt_stripe), INTENT(in) :: stripes(:)
228  INTEGER(xt_int_kind), INTENT(in) :: ref_indices(:)
229 
230  TYPE(xt_idxlist) :: idxvec
231  idxvec = xt_idxvec_from_stripes_new(stripes)
232  CALL check_idxlist(idxvec, ref_indices)
233  CALL xt_idxlist_delete(idxvec)
234  END SUBROUTINE test_idxvec_from_stripes
235 
236  SUBROUTINE test_stripes1
237  TYPE(xt_stripe), PARAMETER :: stripes(2) = &
238  (/ xt_stripe(5, 1, 5), xt_stripe(4, -1, 5) /)
239  INTEGER(xt_int_kind), PARAMETER :: ref_indices(10) &
240  = (/ 5_xi, 6_xi, 7_xi, 8_xi, 9_xi, 4_xi, 3_xi, 2_xi, 1_xi, 0_xi /)
241  CALL test_idxvec_from_stripes(stripes, ref_indices)
242  END SUBROUTINE test_stripes1
243 
244  SUBROUTINE test_stripes2
245  TYPE(xt_stripe), PARAMETER :: stripes(3) &
246  = (/ xt_stripe(0, 1, 5), xt_stripe(2, 1, 5), xt_stripe(4, 1, 5) /)
247  INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
248  = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, &
249  & 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, &
250  & 4_xi, 5_xi, 6_xi, 7_xi, 8_xi /)
251  CALL test_idxvec_from_stripes(stripes, ref_indices)
252  END SUBROUTINE test_stripes2
253 
254  SUBROUTINE test_stripes3
255  TYPE(xt_stripe), PARAMETER :: stripes(3) &
256  = (/ xt_stripe(2, 1, 5), xt_stripe(0, 1, 5), xt_stripe(4, 1, 5) /)
257  INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
258  = (/ 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, &
259  & 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, &
260  & 4_xi, 5_xi, 6_xi, 7_xi, 8_xi /)
261  CALL test_idxvec_from_stripes(stripes, ref_indices)
262  END SUBROUTINE test_stripes3
263 
264  SUBROUTINE test_stripes4
265  TYPE(xt_stripe), PARAMETER :: stripes(3) &
266  = (/ xt_stripe(2, 1, 5), xt_stripe(4, -1, 5), xt_stripe(4, 1, 5) /)
267  INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
268  = (/ 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, &
269  & 4_xi, 3_xi, 2_xi, 1_xi, 0_xi, &
270  & 4_xi, 5_xi, 6_xi, 7_xi, 8_xi /)
271  CALL test_idxvec_from_stripes(stripes, ref_indices)
272  END SUBROUTINE test_stripes4
273 
274  SUBROUTINE test_stripes5
275  TYPE(xt_stripe), PARAMETER :: stripes(3) &
276  = (/ xt_stripe(0, 3, 5), xt_stripe(1, 3, 5), xt_stripe(14, -3, 5) /)
277  INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
278  = (/ 0_xi, 3_xi, 6_xi, 9_xi, 12_xi, &
279  & 1_xi, 4_xi, 7_xi, 10_xi, 13_xi, &
280  & 14_xi, 11_xi, 8_xi, 5_xi, 2_xi /)
281  CALL test_idxvec_from_stripes(stripes, ref_indices)
282  END SUBROUTINE test_stripes5
283 
284  SUBROUTINE test_stripes6
285  TYPE(xt_stripe), PARAMETER :: stripes(3) &
286  = (/ xt_stripe(0, 3, 5), xt_stripe(2, 3, 5), xt_stripe(14, -3, 5) /)
287  INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
288  = (/ 0_xi, 3_xi, 6_xi, 9_xi, 12_xi, &
289  & 2_xi, 5_xi, 8_xi, 11_xi, 14_xi, &
290  & 14_xi, 11_xi, 8_xi, 5_xi, 2_xi /)
291  CALL test_idxvec_from_stripes(stripes, ref_indices)
292  END SUBROUTINE test_stripes6
293 
294  SUBROUTINE test_stripes7
295  TYPE(xt_stripe), PARAMETER :: stripes(4) = (/ xt_stripe(0, -1, 5), &
296  xt_stripe(1, 1, 5), xt_stripe(-5, -1, 5), xt_stripe(6, 1, 5) /)
297  INTEGER(xt_int_kind), PARAMETER :: ref_indices(20) &
298  = (/ 0_xi, -1_xi, -2_xi, -3_xi, -4_xi, &
299  & 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, &
300  & -5_xi, -6_xi, -7_xi, -8_xi, -9_xi, &
301  & 6_xi, 7_xi, 8_xi, 9_xi, 10_xi /)
302  CALL test_idxvec_from_stripes(stripes, ref_indices)
303  END SUBROUTINE test_stripes7
304 
305  SUBROUTINE test_get_indices_at_positions(indices, undef_idx, pos)
306  INTEGER(xt_int_kind), INTENT(in) :: indices(:), undef_idx
307  INTEGER, INTENT(in) :: pos(:)
308  INTEGER(xt_int_kind) :: ref_sel_idx(size(pos)), sel_idx(size(pos))
309  INTEGER :: i, num_pos, undef_count, ref_undef_count
310  TYPE(xt_idxlist) :: idxvec
311  CHARACTER(80) :: msg
312  num_pos = SIZE(pos)
313  idxvec = xt_idxvec_new(indices, SIZE(indices))
314  ref_undef_count = 0
315  DO i = 1, num_pos
316  IF (xt_idxlist_get_index_at_position(idxvec, pos(i), ref_sel_idx(i))) &
317  THEN
318  ref_sel_idx(i) = undef_idx
319  ref_undef_count = ref_undef_count + 1
320  END IF
321  END DO
322  undef_count = xt_idxlist_get_indices_at_positions(idxvec, pos, sel_idx, &
323  undef_idx)
324  IF (undef_count /= ref_undef_count) THEN
325  CALL test_abort("test_idxvec_f.f90: (undef_count /= ref_undef_count)", &
326  __file__, &
327  __line__)
328  END IF
329  DO i = 1, num_pos
330  IF (sel_idx(i) /= ref_sel_idx(i)) THEN
331  WRITE (msg, '(2(a,i0),a)') "test_idxvec_f.f90: (sel_idx(", i, &
332  ") /= ref_sel_idx(", i, "))"
333  CALL test_abort(msg, &
334  __file__, &
335  __line__)
336  END IF
337  END DO
338  CALL xt_idxlist_delete(idxvec)
339  END SUBROUTINE test_get_indices_at_positions
340 
341  SUBROUTINE test_get_indices_at_positions1
342  INTEGER(xt_int_kind), PARAMETER :: indices(16) &
343  = (/ 0_xi, 3_xi, 6_xi, 9_xi, 12_xi, 1_xi, 4_xi, 7_xi, &
344  & 10_xi, 13_xi, 14_xi, 11_xi, 8_xi, 5_xi, 2_xi, 1_xi /)
345  INTEGER(xt_int_kind), PARAMETER :: undef_idx = -huge(undef_idx)
346  INTEGER, PARAMETER :: pos(13) &
347  = (/ 0, 2, 7, 9, 11, 100, 11, 200, 9, 300, 7, 400, 5 /)
348  CALL test_get_indices_at_positions(indices, undef_idx, pos)
349  END SUBROUTINE test_get_indices_at_positions1
350 
351  SUBROUTINE test_get_indices_at_positions2
352  INTEGER(xt_int_kind), PARAMETER :: indices(16) &
353  = (/ 0_xi, 3_xi, 6_xi, 9_xi, 12_xi, 1_xi, 4_xi, 7_xi, &
354  & 10_xi, 13_xi, 14_xi, 11_xi, 8_xi, 5_xi, 2_xi, 1_xi /)
355  INTEGER(xt_int_kind), PARAMETER :: undef_idx = -huge(undef_idx)
356  INTEGER, PARAMETER :: pos(9) &
357  = (/ 0, 2, 7, 9, 11, 11, 9, 7, 5 /)
358  CALL test_get_indices_at_positions(indices, undef_idx, pos)
359  END SUBROUTINE test_get_indices_at_positions2
360 
361  SUBROUTINE test_get_indices_at_positions3
362  INTEGER(xt_int_kind), PARAMETER :: indices(16) &
363  = (/ 0_xi, 3_xi, 6_xi, 9_xi, 12_xi, 1_xi, 4_xi, 7_xi, &
364  & 10_xi, 13_xi, 14_xi, 11_xi, 8_xi, 5_xi, 2_xi, 1_xi /)
365  INTEGER(xt_int_kind), PARAMETER :: undef_idx = -huge(indices(1))
366  INTEGER, PARAMETER :: pos(9) &
367  = (/ 100, 102, 107, 109, 1011, 1011, 109, 107, 105 /)
368  CALL test_get_indices_at_positions(indices, undef_idx, pos)
369  END SUBROUTINE test_get_indices_at_positions3
370 
371  SUBROUTINE test_get_positions_of_indices
372  INTEGER(xt_int_kind), PARAMETER :: indices(2) = (/ 0_xi, 2_xi /), &
373  selection(3) = (/ 1_xi, 2_xi, 3_xi /)
374  INTEGER :: i, position, positions(size(selection))
375  INTEGER, PARAMETER :: ref_positions(3) = (/ -1, 1, -1 /)
376  TYPE(xt_idxlist) :: idxvec
377 
378  idxvec = xt_idxvec_new(indices, SIZE(indices))
379  IF (.NOT. xt_idxlist_get_position_of_index(idxvec, 1_xt_int_kind, &
380  position)) &
381  CALL test_abort('xt_idxlist_get_position_of_index did not return &
382  &an error', &
383  __file__, &
384  __line__)
385  IF (.NOT. xt_idxlist_get_position_of_index_off(idxvec, 1_xt_int_kind, &
386  position, 0)) &
387  CALL test_abort('xt_idxlist_get_position_of_index_off did not return &
388  &an error', &
389  __file__, &
390  __line__)
391  IF (.NOT. xt_idxlist_get_position_of_index_off(idxvec, 0_xt_int_kind, &
392  position, 1)) &
393  CALL test_abort('xt_idxlist_get_position_of_index_off did not return &
394  &an error', &
395  __file__, &
396  __line__)
397  IF (xt_idxlist_get_positions_of_indices(idxvec, selection, positions, &
398  .false.) /= 2) THEN
399  CALL test_abort('xt_idxlist_get_positions_of_indices did not return &
400  &correct number of matches', &
401  __file__, &
402  __line__)
403  END IF
404  DO i = 1, SIZE(selection)
405  IF (positions(i) /= ref_positions(i)) &
406  CALL test_abort('xt_idxlist_get_positions_of_indices returned &
407  &incorrect position', &
408  __file__, &
409  __line__)
410  END DO
411  CALL xt_idxlist_delete(idxvec)
412  END SUBROUTINE test_get_positions_of_indices
413 
414  SUBROUTINE test_bounding_box(indices, global_size, global_start_index, &
415  ref_bounds)
416  INTEGER(xt_int_kind), INTENT(in) :: indices(:), global_size(:), &
417  global_start_index
418  TYPE(xt_bounds), INTENT(in) :: ref_bounds(:)
419 
420  TYPE(xt_bounds) :: bounds(size(global_size))
421  INTEGER :: i, ndim
422  TYPE(xt_idxlist) :: idxvec
423  CHARACTER(80) :: msg
424 
425  ndim = SIZE(global_size)
426  IF (SIZE(ref_bounds) /= ndim) &
427  CALL test_abort('ERROR: inequal dimensions', &
428  __file__, &
429  __line__)
430 
431  idxvec = xt_idxvec_new(indices, SIZE(indices))
432 
433  bounds = xt_idxlist_get_bounding_box(idxvec, global_size, &
434  global_start_index)
435 
436  DO i = 1, ndim
437  IF (bounds(i)%start /= ref_bounds(i)%start) THEN
438  WRITE (0, '(2(a,i0))') 'bounds(', i, ')%start=', bounds(i)%start
439  WRITE (0, '(2(a,i0))') 'ref_bounds(', i, ')%start=', ref_bounds(i)%start
440  WRITE (msg, '(a,i0)') "ERROR: xt_idxlist_get_bounding_box inequal &
441  &starts at i=", i
442  CALL test_abort(msg, &
443  __file__, &
444  __line__)
445  END IF
446  IF (bounds(i)%size /= ref_bounds(i)%size) THEN
447  WRITE (0, '(2(a,i0))') 'bounds(', i, ')%size=', bounds(i)%size
448  WRITE (0, '(2(a,i0))') 'ref_bounds(', i, ')%size=', ref_bounds(i)%size
449  WRITE (msg, '(a,i0)') "ERROR: xt_idxlist_get_bounding_box inequal &
450  &size at i=", i
451  CALL test_abort(msg, &
452  __file__, &
453  __line__)
454  END IF
455  END DO
456  CALL xt_idxlist_delete(idxvec)
457  END SUBROUTINE test_bounding_box
458 
459  SUBROUTINE test_bounding_box1
460  INTEGER(xt_int_kind), PARAMETER :: indices(2) = (/ 21_xi, 42_xi /), &
461  global_size(3) = 4_xi, global_start_index = 0_xi
462  TYPE(xt_bounds), PARAMETER :: ref_bounds(3) = xt_bounds(1_xi, 2_xi)
463  CALL test_bounding_box(indices, global_size, global_start_index, ref_bounds)
464  END SUBROUTINE test_bounding_box1
465 
466  SUBROUTINE test_bounding_box2
467  INTEGER(xt_int_kind), PARAMETER :: indices(5) &
468  = (/ 45_xi, 35_xi, 32_xi, 48_xi, 33_xi /), &
469  global_size(3) = (/ 5_xi, 4_xi, 3_xi /), global_start_index = 1_xi
470  TYPE(xt_bounds), PARAMETER :: ref_bounds(3) &
471  = (/ xt_bounds(2, 2), xt_bounds(2, 2), xt_bounds(1, 2) /)
472  CALL test_bounding_box(indices, global_size, global_start_index, ref_bounds)
473  END SUBROUTINE test_bounding_box2
474 
475  SUBROUTINE test_bounding_box3
476  INTEGER(xt_int_kind), PARAMETER :: indices(1) = (/ -1_xi /), &
477  global_size(3) = 4_xi, global_start_index = 0_xi
478  TYPE(xt_bounds), PARAMETER :: ref_bounds(3) = xt_bounds(0, 0)
479  CALL test_bounding_box(indices(1:0), global_size, global_start_index, &
480  ref_bounds)
481  END SUBROUTINE test_bounding_box3
482 
483  SUBROUTINE setup_idxvec(idxlist, index_vector)
484  TYPE(xt_idxlist), INTENT(out) :: idxlist
485  INTEGER(xt_int_kind), INTENT(in) :: index_vector(:)
486 
487  idxlist = xt_idxvec_new(index_vector, SIZE(index_vector))
488  CALL check_idxlist(idxlist, index_vector)
489  END SUBROUTINE setup_idxvec
490 
491  SUBROUTINE compare_stripes(idxlist, ref_stripes)
492  TYPE(xt_idxlist), INTENT(in) :: idxlist
493  TYPE(xt_stripe), INTENT(in) :: ref_stripes(:)
494 
495  TYPE(xt_stripe), ALLOCATABLE :: stripes(:)
496 
497  CALL xt_idxlist_get_index_stripes(idxlist, stripes)
498 
499  CALL check_stripes(stripes, ref_stripes)
500 
501  END SUBROUTINE compare_stripes
502 
503 END PROGRAM test_idxvec
504 !
505 ! Local Variables:
506 ! f90-continuation-indent: 5
507 ! coding: utf-8
508 ! indent-tabs-mode: nil
509 ! show-trailing-whitespace: t
510 ! require-trailing-newline: t
511 ! End:
512 !
Generated by   doxygen 1.8.13