Yet Another eXchange Tool  0.9.0
test_idxstripes_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_idxstripes_f
48  USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort, &
49  run_randomized_tests, init_fortran_random
50  USE mpi
51  USE test_idxlist_utils, ONLY: check_idxlist, test_err_count, &
52  idxlist_pack_unpack_copy
53  USE yaxt, ONLY: xt_initialize, xt_finalize, xt_bounds, xt_pos_ext, &
54  xt_stripe, xt_idxlist, xt_idxlist_delete, xt_idxstripes_new, &
59  xt_idxlist_get_bounding_box, OPERATOR(/=), &
63  USE iso_c_binding, ONLY: c_int
64  IMPLICIT NONE
65  INTEGER, PARAMETER :: xi = xt_int_kind
66  LOGICAL :: fully_random_tests
67  CHARACTER(len=*), PARAMETER :: filename = 'test_idxstripes_f.f90'
68 
69  CALL init_mpi
70  CALL xt_initialize(mpi_comm_world)
71  CALL stripe_test_general1
72  CALL stripe_test_general2
73  CALL stripe_test_general3
74  CALL stripe_test_general4
75  CALL stripe_test_general5
76  CALL stripe_test_general6
77  CALL test_intersection0
78  CALL test_intersection1
79  CALL test_intersection2
80  CALL test_intersection3
81  CALL test_intersection4
82  CALL test_intersection5
83  CALL test_intersection6
84  CALL test_intersection7
85  CALL test_intersection8
86  CALL test_intersection9
87  CALL test_intersection10
88  CALL test_intersection11
89  CALL test_intersection12
90  CALL test_intersection13
91  CALL test_intersection14
92  CALL test_intersection15
93  CALL test_intersection_stripe2vec
94  CALL test_idxlist_stripes_pos_ext1
95  CALL test_idxlist_stripes_pos_ext2
96  CALL test_idxlist_stripes_pos_ext3
97 #if SIZEOF_XT_INT > 2
98  CALL test_idxlist_stripes_pos_ext4
99  CALL test_idxlist_stripes_pos_ext5
100 #endif
101  CALL test_idxlist_stripes_pos_ext_randomized1(.false.)
102  fully_random_tests = run_randomized_tests()
103  IF (fully_random_tests) &
104  CALL test_idxlist_stripes_pos_ext_randomized1(.true.)
105  CALL test_get_pos1
106  CALL test_get_pos2
107  CALL test_get_pos3
108  CALL test_get_pos4
109  CALL test_stripe_overlap
110  CALL test_stripe_bb1
111  CALL test_stripe_bb2
112  CALL check_pos_ext1
113  CALL check_pos_ext2
114  CALL check_pos_ext3
115  CALL check_pos_ext4
116  CALL check_pos_ext5
117  CALL check_pos_ext6
118  CALL check_pos_ext7
119  CALL check_pos_ext8
120  IF (test_err_count() /= 0) &
121  CALL test_abort("non-zero error count!", filename, __line__)
122  CALL xt_finalize
123  CALL finish_mpi
124 
125 CONTAINS
126  SUBROUTINE stripe_test_general(stripes, ref_indices)
127  TYPE(xt_stripe), INTENT(in) :: stripes(:)
128  INTEGER(xt_int_kind), INTENT(in) :: ref_indices(:)
129 
130  TYPE(xt_idxlist) :: idxstripes, idxvec
131  INTEGER :: num_ext, num_unmatched, num_pos, i
132  INTEGER(c_int) :: ext_size
133  TYPE(xt_pos_ext), ALLOCATABLE :: pos_ext(:)
134 
135  idxstripes = xt_idxstripes_new(stripes, SIZE(stripes))
136  CALL do_tests(idxstripes, ref_indices)
137 
138  num_unmatched = xt_idxlist_get_pos_exts_of_index_stripes(idxstripes, &
139  stripes, pos_ext, .true.)
140  IF (num_unmatched /= 0) &
141  CALL test_abort("stripes not found", filename, __line__)
142 
143  num_pos = 0
144  IF (ALLOCATED(pos_ext)) THEN
145  num_ext = SIZE(pos_ext)
146  ELSE
147  num_ext = 0
148  END IF
149  DO i = 1, num_ext
150  ext_size = pos_ext(i)%size
151  IF (num_pos /= pos_ext(i)%start) &
152  CALL test_abort("position/start mismatch", filename, __line__)
153  num_pos = num_pos + ext_size
154  END DO
155  IF (num_pos /= xt_idxlist_get_num_indices(idxstripes)) &
156  CALL test_abort("index list length/positions overlap mismatch", &
157  filename, __line__)
158 
159  IF (ALLOCATED(pos_ext)) DEALLOCATE(pos_ext)
160  CALL xt_idxlist_delete(idxstripes)
161 
162  ! test recreation of stripes from reference vector
163  idxvec = xt_idxvec_new(ref_indices)
164  idxstripes = xt_idxstripes_from_idxlist_new(idxvec)
165  CALL check_idxlist(idxstripes, ref_indices)
166  CALL xt_idxlist_delete(idxvec)
167  CALL xt_idxlist_delete(idxstripes)
168  END SUBROUTINE stripe_test_general
169 
170  SUBROUTINE stripe_test_general1
171  TYPE(xt_stripe), PARAMETER :: stripes(3) = (/ xt_stripe(0, 1, 5), &
172  xt_stripe(10, 1, 5), xt_stripe(20, 1, 5) /);
173  INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
174  = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, &
175  & 10_xi, 11_xi, 12_xi, 13_xi, 14_xi, &
176  & 20_xi, 21_xi, 22_xi, 23_xi, 24_xi /)
177  CALL stripe_test_general(stripes, ref_indices)
178  END SUBROUTINE stripe_test_general1
179 
180  SUBROUTINE stripe_test_general2
181  TYPE(xt_stripe), PARAMETER :: stripes(3) = (/ xt_stripe(0, 1, 5), &
182  xt_stripe(10, 2, 5), xt_stripe(20, 3, 5) /)
183  INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
184  = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, &
185  & 10_xi, 12_xi, 14_xi, 16_xi, 18_xi, &
186  & 20_xi, 23_xi, 26_xi, 29_xi, 32_xi /)
187  CALL stripe_test_general(stripes, ref_indices)
188  END SUBROUTINE stripe_test_general2
189 
190  SUBROUTINE stripe_test_general3
191  TYPE(xt_stripe), PARAMETER :: stripes(2) = (/ xt_stripe(0, 6, 5), &
192  xt_stripe(1, 3, 5) /)
193  INTEGER(xt_int_kind), PARAMETER :: ref_indices(10) &
194  = (/ 0_xi, 6_xi, 12_xi, 18_xi, 24_xi, &
195  & 1_xi, 4_xi, 7_xi, 10_xi, 13_xi /)
196  CALL stripe_test_general(stripes, ref_indices)
197  END SUBROUTINE stripe_test_general3
198 
199  SUBROUTINE stripe_test_general4
200  TYPE(xt_stripe), PARAMETER :: stripes(2) = (/ xt_stripe(0, -1, 5), &
201  xt_stripe(1, 1, 5) /)
202  INTEGER(xt_int_kind), PARAMETER :: ref_indices(10) &
203  = (/ 0_xi, -1_xi, -2_xi, -3_xi, -4_xi, &
204  & 1_xi, 2_xi, 3_xi, 4_xi, 5_xi /)
205  CALL stripe_test_general(stripes, ref_indices)
206  END SUBROUTINE stripe_test_general4
207 
208  SUBROUTINE stripe_test_general5
209  TYPE(xt_stripe), PARAMETER :: stripes(2) = (/ xt_stripe(9, -2, 5), &
210  xt_stripe(0, 2, 5) /)
211  INTEGER(xt_int_kind), PARAMETER :: ref_indices(10) &
212  = (/ 9_xi, 7_xi, 5_xi, 3_xi, 1_xi, &
213  & 0_xi, 2_xi, 4_xi, 6_xi, 8_xi /)
214  CALL stripe_test_general(stripes, ref_indices)
215  END SUBROUTINE stripe_test_general5
216 
217  SUBROUTINE stripe_test_general6
218  TYPE(xt_stripe), PARAMETER :: stripes(1) = (/ xt_stripe(179, -2, 0) /)
219  INTEGER(xt_int_kind), PARAMETER :: ref_indices(1) = (/ 0_xi /)
220  CALL stripe_test_general(stripes, ref_indices(1:0))
221  END SUBROUTINE stripe_test_general6
222 
223  SUBROUTINE test_intersection(stripes_a, stripes_b, ref_indices_a, ref_indices_b)
224  TYPE(xt_stripe), INTENT(in) :: stripes_a(:), stripes_b(:)
225  INTEGER(xt_int_kind), INTENT(in) :: ref_indices_a(:)
226  INTEGER(xt_int_kind), OPTIONAL, INTENT(in) :: ref_indices_b(:)
227  TYPE(xt_idxlist) :: idxstripes_a, idxstripes_b, intersection(2)
228 
229  idxstripes_a = xt_idxstripes_new(stripes_a)
230  idxstripes_b = xt_idxstripes_new(stripes_b)
231  intersection(1) = xt_idxlist_get_intersection(idxstripes_a, idxstripes_b)
232  intersection(2) = xt_idxlist_get_intersection(idxstripes_b, idxstripes_a)
233  CALL do_tests(intersection(1), ref_indices_a)
234  IF (PRESENT(ref_indices_b)) THEN
235  CALL do_tests(intersection(2), ref_indices_b)
236  ELSE
237  CALL do_tests(intersection(2), ref_indices_a)
238  END IF
239  CALL xt_idxlist_delete(intersection(2))
240  CALL xt_idxlist_delete(intersection(1))
241  CALL xt_idxlist_delete(idxstripes_a)
242  CALL xt_idxlist_delete(idxstripes_b)
243  END SUBROUTINE test_intersection
244 
245  SUBROUTINE test_intersection0
246  TYPE(xt_stripe), PARAMETER :: stripes_a(1) = (/ xt_stripe(0, 0, 0) /), &
247  stripes_b(1) = (/ xt_stripe(1, 1, 8) /)
248  INTEGER(xt_int_kind), PARAMETER :: ref_indices(1) = (/ 0_xi /)
249  CALL test_intersection(stripes_a(1:0), stripes_b, ref_indices(1:0))
250  END SUBROUTINE test_intersection0
251 
252  SUBROUTINE test_intersection1
253  TYPE(xt_stripe), PARAMETER :: stripes_a(2) = (/ xt_stripe(0, 1, 4), &
254  xt_stripe(6, 1, 4) /), &
255  stripes_b(1) = (/ xt_stripe(1, 1, 8) /)
256  INTEGER(xt_int_kind), PARAMETER :: ref_indices(6) &
257  = (/ 1_xi, 2_xi, 3_xi, 6_xi, 7_xi, 8_xi /)
258  CALL test_intersection(stripes_a, stripes_b, ref_indices)
259  END SUBROUTINE test_intersection1
260 
261  SUBROUTINE test_intersection2
262  TYPE(xt_stripe), PARAMETER :: stripes_a(3) = (/ xt_stripe(0, 1, 4), &
263  xt_stripe(6, 1, 4), xt_stripe(11, 1, 4) /), &
264  stripes_b(2) = (/ xt_stripe(1, 1, 7), xt_stripe(9, 1, 5) /)
265  INTEGER(xt_int_kind), PARAMETER :: ref_indices(9) &
266  = (/ 1_xi, 2_xi, 3_xi, 6_xi, 7_xi, 9_xi, 11_xi, 12_xi, 13_xi /)
267  CALL test_intersection(stripes_a, stripes_b, ref_indices)
268  END SUBROUTINE test_intersection2
269 
270  SUBROUTINE test_intersection3
271  TYPE(xt_stripe), PARAMETER :: stripes_a(2) = (/ xt_stripe(0, 1, 3), &
272  xt_stripe(8, 1, 3) /), &
273  stripes_b(2) = (/ xt_stripe(3, 1, 5), xt_stripe(11, 1, 3) /)
274  INTEGER(xt_int_kind), PARAMETER :: ref_indices(1) = (/ -1_xi /)
275  CALL test_intersection(stripes_a, stripes_b, ref_indices(1:0))
276  END SUBROUTINE test_intersection3
277 
278  SUBROUTINE test_intersection4
279  TYPE(xt_stripe), PARAMETER :: stripes_a(1) = (/ xt_stripe(0, 1, 10) /), &
280  stripes_b(2) = (/ xt_stripe(0, 2, 5), xt_stripe(9, -2, 5) /)
281  INTEGER(xt_int_kind), PARAMETER :: ref_indices(10) &
282  = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, 7_xi, 8_xi, 9_xi /)
283  CALL test_intersection(stripes_a, stripes_b, ref_indices)
284  END SUBROUTINE test_intersection4
285 
286  SUBROUTINE test_intersection5
287  TYPE(xt_stripe), PARAMETER :: stripes_a(2) = (/ xt_stripe(0, 3, 5), &
288  xt_stripe(1, 7, 5) /), &
289  stripes_b(2) = (/ xt_stripe(0, 2, 7), xt_stripe(24, -1, 10) /)
290  INTEGER(xt_int_kind), PARAMETER :: ref_indices(6) &
291  = (/ 0_xi, 6_xi, 8_xi, 12_xi, 15_xi, 22_xi /)
292  CALL test_intersection(stripes_a, stripes_b, ref_indices)
293  END SUBROUTINE test_intersection5
294 
295  SUBROUTINE test_intersection6
296  TYPE(xt_stripe), PARAMETER :: stripes_a(1) = (/ xt_stripe(0, 1, 10) /), &
297  stripes_b(2) = (/ xt_stripe(5, 1, 5), xt_stripe(4, -1, 5) /)
298  INTEGER(xt_int_kind), PARAMETER :: ref_indices(10) &
299  = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, 7_xi, 8_xi, 9_xi /)
300  CALL test_intersection(stripes_a, stripes_b, ref_indices)
301  END SUBROUTINE test_intersection6
302 
303  SUBROUTINE test_intersection7
304  TYPE(xt_stripe), PARAMETER :: stripes_a(2) = (/ xt_stripe(0, 1, 10) , &
305  xt_stripe(20, 1, 5) /), &
306  stripes_b(2) = (/ xt_stripe(3, 1, 5), xt_stripe(17, 1, 5) /)
307  INTEGER(xt_int_kind), PARAMETER :: ref_indices(7) &
308  = (/ 3_xi, 4_xi, 5_xi, 6_xi, 7_xi, 20_xi, 21_xi /)
309  CALL test_intersection(stripes_a, stripes_b, ref_indices)
310  END SUBROUTINE test_intersection7
311 
312  SUBROUTINE test_intersection8
313  TYPE(xt_stripe), PARAMETER :: stripes_a(10) = (/ xt_stripe(0, 1, 2), &
314  xt_stripe(3, 1, 2), xt_stripe(5, 1, 2), xt_stripe(8, 1, 2), &
315  xt_stripe(10, 1, 2), xt_stripe(14, 1, 2), xt_stripe(17, 1, 2), &
316  xt_stripe(20, 1, 2), xt_stripe(23, 1, 2), xt_stripe(25, 1, 2) /), &
317  stripes_b(5) = (/ xt_stripe(5, 1, 3), xt_stripe(8, 1, 2), &
318  xt_stripe(19, 1, 1), xt_stripe(20, 1, 2), xt_stripe(30, 1, 2) /)
319  INTEGER(xt_int_kind), PARAMETER :: ref_indices(6) &
320  = (/ 5_xi, 6_xi, 8_xi, 9_xi, 20_xi, 21_xi /)
321  CALL test_intersection(stripes_a, stripes_b, ref_indices)
322  END SUBROUTINE test_intersection8
323 
324  SUBROUTINE test_intersection9
325  TYPE(xt_stripe), PARAMETER :: stripes_a(3) = (/ xt_stripe(0, 1, 5), &
326  xt_stripe(1, 1, 5), xt_stripe(2, 1, 5) /), &
327  stripes_b(1) = (/ xt_stripe(-2, 1, 10) /)
328 #ifndef __G95__
329  INTEGER(xi) :: i
330  INTEGER(xt_int_kind), PARAMETER :: ref_indices_a(7) &
331  = (/ (i, i=0_xi,6_xi) /), &
332 #else
333  INTEGER :: i
334  INTEGER(xt_int_kind), PARAMETER :: ref_indices_a(7) &
335  = (/ (int(i, xi), i=0_xi,6_xi) /), &
336 #endif
337  ref_indices_b(15) = (/ 0_xi, 1_xi, 1_xi, 2_xi, 2_xi, 2_xi, 3_xi, &
338  & 3_xi, 3_xi, 4_xi, 4_xi, 4_xi, 5_xi, 5_xi, 6_xi /)
339  CALL test_intersection(stripes_a, stripes_b, ref_indices_a, ref_indices_b)
340  END SUBROUTINE test_intersection9
341 
342  SUBROUTINE test_intersection10
343  TYPE(xt_stripe), PARAMETER :: stripes_a(1) = (/ xt_stripe(0, 2, 5) /), &
344  stripes_b(1) = (/ xt_stripe(1, 2, 5) /)
345  INTEGER(xt_int_kind), PARAMETER :: dummy(1) = (/ -1_xi /)
346  CALL test_intersection(stripes_a, stripes_b, dummy(1:0))
347  END SUBROUTINE test_intersection10
348 
349  SUBROUTINE test_intersection11
350  TYPE(xt_stripe), PARAMETER :: stripes_a(1) = (/ xt_stripe(0, 5, 20) /), &
351  stripes_b(1) = (/ xt_stripe(1, 7, 15) /)
352  INTEGER(xt_int_kind), PARAMETER :: ref_indices(3) = (/ 15_xi, 50_xi, 85_xi /)
353  CALL test_intersection(stripes_a, stripes_b, ref_indices)
354  END SUBROUTINE test_intersection11
355 
356  ! both ranges overlap in range but have no
357  ! indices in common because of stride
358  SUBROUTINE test_intersection12
359  TYPE(xt_stripe), PARAMETER :: stripes_a(1) = (/ xt_stripe(34, 29, 12) /), &
360  stripes_b(1) = (/ xt_stripe(36, 7, 2) /)
361  INTEGER(xt_int_kind), PARAMETER :: dummy(1) = (/ -1_xi /)
362 
363  CALL test_intersection(stripes_a, stripes_b, dummy(1:0))
364  END SUBROUTINE test_intersection12
365 
366  ! same as test_intersection12 but with negative stride
367  SUBROUTINE test_intersection13
368  TYPE(xt_stripe), PARAMETER :: &
369  stripes_a(1) = (/ xt_stripe(353, -29, 12) /), &
370  stripes_b(1) = (/ xt_stripe(36, 7, 2) /)
371  INTEGER(xt_int_kind), PARAMETER :: dummy(1) = (/ -1_xi /)
372 
373  CALL test_intersection(stripes_a, stripes_b, dummy(1:0))
374  END SUBROUTINE test_intersection13
375 
376  SUBROUTINE test_intersection14
377  TYPE(xt_stripe), PARAMETER :: &
378  stripes_a(1) = (/ xt_stripe(95, -29, 2) /), &
379  stripes_b(1) = (/ xt_stripe(81, 14, 2) /)
380  INTEGER(xt_int_kind), PARAMETER :: ref_indices(1) = (/ 95_xi /)
381 
382  CALL test_intersection(stripes_a, stripes_b, ref_indices)
383  END SUBROUTINE test_intersection14
384 
385  SUBROUTINE test_intersection15
386  TYPE(xt_stripe), PARAMETER :: &
387  stripes_a(1) = (/ xt_stripe(546, 14, 2) /), &
388  stripes_b(1) = (/ xt_stripe(354, 206, 2) /)
389  INTEGER(xt_int_kind), PARAMETER :: ref_indices(1) = (/ 560_xi /)
390 
391  CALL test_intersection(stripes_a, stripes_b, ref_indices)
392  END SUBROUTINE test_intersection15
393 
394  SUBROUTINE test_intersection_stripe2vec
395  INTEGER, PARAMETER :: num_stripes = 3
396  TYPE(xt_stripe), PARAMETER :: stripes(num_stripes) &
397  = (/ xt_stripe(4, 1, 1), xt_stripe(5, 1, 1), xt_stripe(10, -10, 2) /)
398  TYPE(xt_idxlist) :: idxvec_a, idxvec_b, intersection
399  INTEGER(xt_int_kind), PARAMETER :: index_vector(1) = (/ 5_xi /)
400  INTEGER(xt_int_kind) :: intersection_idx
401  LOGICAL :: not_found
402  idxvec_a = xt_idxvec_from_stripes_new(stripes)
403  idxvec_b = xt_idxvec_new(index_vector)
404  intersection = xt_idxlist_get_intersection(idxvec_a, idxvec_b)
405  IF (xt_idxlist_get_num_indices(intersection) /= 1) &
406  CALL test_abort("unexpected number of indices in intersection!", &
407  filename, __line__)
408  not_found = xt_idxlist_get_index_at_position(intersection, 0, &
409  intersection_idx)
410  IF (not_found .OR. intersection_idx /= index_vector(1)) &
411  CALL test_abort("unexpected index in intersection!", &
412  filename, __line__)
413  CALL xt_idxlist_delete(intersection)
414  CALL xt_idxlist_delete(idxvec_a)
415  CALL xt_idxlist_delete(idxvec_b)
416  END SUBROUTINE test_intersection_stripe2vec
417 
418  SUBROUTINE test_idxlist_stripes_pos_ext1
419  INTEGER, PARAMETER :: num_indices = 223
420  INTEGER(xt_int_kind), PARAMETER :: index_vector(num_indices) = (/ &
421  3375_xi, 3376_xi, 3379_xi, 3380_xi, 3381_xi, 3387_xi, 3388_xi, &
422  3389_xi, 3390_xi, 3391_xi, 3392_xi, 3393_xi, 3421_xi, 3422_xi, &
423  3423_xi, 3424_xi, 3425_xi, 3426_xi, 3427_xi, 3444_xi, 3458_xi, &
424  3459_xi, 3461_xi, 3462_xi, 3463_xi, 3464_xi, 3465_xi, 3466_xi, &
425  3467_xi, 3468_xi, 3469_xi, 3470_xi, 3471_xi, 3472_xi, 3473_xi, &
426  3474_xi, 3475_xi, 3476_xi, 3477_xi, 3478_xi, 3479_xi, 3480_xi, &
427  3529_xi, 3606_xi, 3607_xi, 3608_xi, 3611_xi, 3612_xi, 3613_xi, &
428  3614_xi, 3617_xi, 3620_xi, 3621_xi, 3622_xi, 3623_xi, 3624_xi, &
429  3625_xi, 3626_xi, 3627_xi, 3628_xi, 3629_xi, 3630_xi, 3631_xi, &
430  3684_xi, 3685_xi, 3686_xi, 3687_xi, 3688_xi, 3689_xi, 3690_xi, &
431  3691_xi, 3692_xi, 3693_xi, 3694_xi, 3695_xi, 3696_xi, 3697_xi, &
432  3698_xi, 3699_xi, 3700_xi, 3701_xi, 3702_xi, 3703_xi, 3704_xi, &
433  3705_xi, 3706_xi, 3707_xi, 3708_xi, 3709_xi, 3713_xi, 3714_xi, &
434  3715_xi, 3716_xi, 3717_xi, 3718_xi, 3719_xi, 3720_xi, 3721_xi, &
435  3722_xi, 3723_xi, 3724_xi, 3725_xi, 3726_xi, 3727_xi, 3728_xi, &
436  3729_xi, 3730_xi, 3731_xi, 3741_xi, 3742_xi, 3931_xi, 3932_xi, &
437  3374_xi, 3382_xi, 3385_xi, 3394_xi, 3404_xi, 3408_xi, 3412_xi, &
438  3440_xi, 3443_xi, 3457_xi, 3481_xi, 3483_xi, 3527_xi, 3619_xi, &
439  3735_xi, 3743_xi, 3925_xi, 3930_xi, 3377_xi, 3378_xi, 3383_xi, &
440  3384_xi, 3386_xi, 3395_xi, 3397_xi, 3398_xi, 3400_xi, 3402_xi, &
441  3403_xi, 3407_xi, 3409_xi, 3410_xi, 3413_xi, 3420_xi, 3441_xi, &
442  3442_xi, 3445_xi, 3448_xi, 3449_xi, 3451_xi, 3460_xi, 3482_xi, &
443  3519_xi, 3520_xi, 3526_xi, 3528_xi, 3530_xi, 3592_xi, 3593_xi, &
444  3595_xi, 3596_xi, 3597_xi, 3609_xi, 3610_xi, 3615_xi, 3616_xi, &
445  3618_xi, 3644_xi, 3710_xi, 3711_xi, 3712_xi, 3732_xi, 3733_xi, &
446  3736_xi, 3737_xi, 3748_xi, 3749_xi, 3753_xi, 3754_xi, 3759_xi, &
447  3760_xi, 3766_xi, 3767_xi, 3919_xi, 3920_xi, 3924_xi, 3926_xi, &
448  3933_xi, 3934_xi, 2589_xi, 2602_xi, 2680_xi, 3326_xi, 3340_xi, &
449  3341_xi, 3396_xi, 3401_xi, 3411_xi, 3414_xi, 3418_xi, 3446_xi, &
450  3447_xi, 3450_xi, 3515_xi, 3521_xi, 3525_xi, 3582_xi, 3590_xi, &
451  3591_xi, 3594_xi, 3642_xi, 3734_xi, 3738_xi, 3747_xi, 3750_xi, &
452  3761_xi, 3765_xi, 3865_xi, 3918_xi, 3923_xi, 3935_xi /)
453  INTEGER, PARAMETER :: num_stripes = 26
454  TYPE(xt_stripe), PARAMETER :: stripes(num_stripes) = (/ &
455  xt_stripe(3326, 14, 2), xt_stripe(3341, 33, 1), &
456  xt_stripe(3374, 1, 25), xt_stripe(3400, 1, 5), &
457  xt_stripe(3407, 1, 8), xt_stripe(3418, 2, 1), &
458  xt_stripe(3420, 1, 8), xt_stripe(3440, 1, 12), &
459  xt_stripe(3457, 1, 27), xt_stripe(3515, 4, 1), &
460  xt_stripe(3519, 1, 3), xt_stripe(3525, 1, 6), &
461  xt_stripe(3582, 8, 1), xt_stripe(3590, 1, 8), &
462  xt_stripe(3606, 1, 26), xt_stripe(3642, 2, 2), &
463  xt_stripe(3684, 1, 55), xt_stripe(3741, 1, 3), &
464  xt_stripe(3747, 1, 4), xt_stripe(3753, 1, 2), &
465  xt_stripe(3759, 1, 3), xt_stripe(3765, 1, 3), &
466  xt_stripe(3865, 53, 1), xt_stripe(3918, 1, 3), &
467  xt_stripe(3923, 1, 4), xt_stripe(3930, 1, 6) /)
468  TYPE(xt_idxlist) :: idxlist
469 
470  idxlist = xt_idxvec_new(index_vector, num_indices)
471  CALL check_idxlist_stripes_pos_ext(idxlist, stripes)
472  CALL xt_idxlist_delete(idxlist)
473  END SUBROUTINE test_idxlist_stripes_pos_ext1
474 
475  SUBROUTINE test_idxlist_stripes_pos_ext2
476  INTEGER, PARAMETER :: num_indices = 201
477  INTEGER(xt_int_kind), PARAMETER :: index_vector(num_indices) = (/ &
478  & 178_xi, 179_xi, 180_xi, 181_xi, 182_xi, 183_xi, 184_xi, &
479  & 186_xi, 187_xi, 188_xi, 189_xi, 190_xi, 194_xi, 195_xi, &
480  & 196_xi, 197_xi, 198_xi, 199_xi, 200_xi, 201_xi, 202_xi, &
481  & 203_xi, 204_xi, 205_xi, 206_xi, 207_xi, 208_xi, 209_xi, &
482  & 210_xi, 211_xi, 212_xi, 217_xi, 223_xi, 426_xi, 428_xi, &
483  & 429_xi, 430_xi, 434_xi, 435_xi, 436_xi, 437_xi, 438_xi, &
484  & 439_xi, 440_xi, 442_xi, 443_xi, 444_xi, 445_xi, 446_xi, &
485  & 447_xi, 448_xi, 449_xi, 450_xi, 451_xi, 452_xi, 453_xi, &
486  & 454_xi, 455_xi, 456_xi, 457_xi, 458_xi, 670_xi, 671_xi, &
487  & 672_xi, 673_xi, 674_xi, 675_xi, 676_xi, 677_xi, 682_xi, &
488  & 684_xi, 685_xi, 686_xi, 687_xi, 688_xi, 689_xi, 690_xi, &
489  & 692_xi, 695_xi, 703_xi, 704_xi, 705_xi, 706_xi, 707_xi, &
490  & 894_xi, 895_xi, 896_xi, 897_xi, 898_xi, 899_xi, 900_xi, &
491  & 901_xi, 906_xi, 907_xi, 908_xi, 913_xi, 915_xi, 921_xi, &
492  & 922_xi, 923_xi, 924_xi, 925_xi, 926_xi, 927_xi, 1096_xi, &
493  & 1097_xi, 1098_xi, 1099_xi, 1100_xi, 1101_xi, 1102_xi, 1103_xi, &
494  & 1107_xi, 1108_xi, 1109_xi, 1110_xi, 1111_xi, 1113_xi, 1114_xi, &
495  & 1119_xi, 1120_xi, 1121_xi, 2095_xi, 2096_xi, 2097_xi, 2098_xi, &
496  & 2100_xi, 2102_xi, 2103_xi, 2104_xi, 2105_xi, 2107_xi, 2108_xi, &
497  & 2109_xi, 2110_xi, 2112_xi, 2118_xi, 2120_xi, 2121_xi, 2122_xi, &
498  & 2123_xi, 2124_xi, 2125_xi, 2127_xi, 2128_xi, 2129_xi, 2130_xi, &
499  & 2134_xi, 2140_xi, 2141_xi, 2142_xi, 2143_xi, 2145_xi, 2148_xi, &
500  & 2149_xi, 2151_xi, 2152_xi, 2153_xi, 2154_xi, 2155_xi, 2156_xi, &
501  & 683_xi, 691_xi, 903_xi, 914_xi, 1105_xi, 1115_xi, 2099_xi, &
502  & 2106_xi, 2111_xi, 2115_xi, 2126_xi, 2132_xi, 2139_xi, 2144_xi, &
503  & 2147_xi, 2150_xi, 2305_xi, 427_xi, 465_xi, 466_xi, 678_xi, &
504  & 693_xi, 902_xi, 909_xi, 1104_xi, 1112_xi, 2101_xi, 2113_xi, &
505  & 2114_xi, 2116_xi, 2117_xi, 2119_xi, 2131_xi, 2136_xi, 2138_xi, &
506  & 2146_xi, 2297_xi, 2302_xi, 2304_xi, 2307_xi /)
507  integer, PARAMETER :: num_stripes = 8
508  TYPE(xt_stripe), PARAMETER :: stripes(num_stripes) = (/ &
509  xt_stripe(670, 1, 9), xt_stripe(682, 1, 12), &
510  xt_stripe(695, 8, 1), xt_stripe(703, 1, 5), &
511  xt_stripe(894, 1, 10), xt_stripe(906, 1, 4), &
512  xt_stripe(913, 1, 3), xt_stripe(921, 1, 7) /)
513  TYPE(xt_idxlist) :: idxlist
514 
515  idxlist = xt_idxvec_new(index_vector)
516  CALL check_idxlist_stripes_pos_ext(idxlist, stripes)
517  CALL xt_idxlist_delete(idxlist)
518  END SUBROUTINE test_idxlist_stripes_pos_ext2
519 
520  SUBROUTINE test_idxlist_stripes_pos_ext3
521  INTEGER, PARAMETER :: num_indices = 1144
522  INTEGER(xt_int_kind), PARAMETER :: index_vector(num_indices) = (/ &
523  2055_xi, 2056_xi, 2060_xi, 2193_xi, 2199_xi, 2203_xi, 2211_xi, 2212_xi, &
524  2278_xi, 2281_xi, 2311_xi, 2312_xi, 2316_xi, 2317_xi, 2322_xi, 2332_xi, &
525  2447_xi, 2448_xi, 2452_xi, 2585_xi, 2591_xi, 2595_xi, 2603_xi, 2604_xi, &
526  2670_xi, 2673_xi, 2703_xi, 2704_xi, 2708_xi, 2709_xi, 2714_xi, 2724_xi, &
527  2839_xi, 2840_xi, 2844_xi, 2977_xi, 2983_xi, 2987_xi, 2995_xi, 2996_xi, &
528  3062_xi, 3065_xi, 3095_xi, 3096_xi, 3100_xi, 3101_xi, 3106_xi, 3116_xi, &
529  3231_xi, 3232_xi, 3236_xi, 3369_xi, 3375_xi, 3379_xi, 3387_xi, 3388_xi, &
530  3454_xi, 3457_xi, 3487_xi, 3488_xi, 3492_xi, 3493_xi, 3498_xi, 3508_xi, &
531  3623_xi, 3624_xi, 3628_xi, 3761_xi, 3767_xi, 3771_xi, 3779_xi, 3780_xi, &
532  3846_xi, 3849_xi, 3879_xi, 3880_xi, 3884_xi, 3885_xi, 3890_xi, 3900_xi, &
533  3997_xi, 4001_xi, 4002_xi, 4053_xi, 4057_xi, 4084_xi, 4085_xi, 4092_xi, &
534  4102_xi, 4188_xi, 4192_xi, 4201_xi, 4373_xi, 4377_xi, 4378_xi, 4429_xi, &
535  4433_xi, 4460_xi, 4461_xi, 4468_xi, 4478_xi, 4564_xi, 4568_xi, 4577_xi, &
536  4749_xi, 4753_xi, 4754_xi, 4805_xi, 4809_xi, 4836_xi, 4837_xi, 4844_xi, &
537  4854_xi, 4945_xi, 4953_xi, 5125_xi, 5129_xi, 5130_xi, 5181_xi, 5185_xi, &
538  5212_xi, 5213_xi, 5220_xi, 5230_xi, 5321_xi, 5329_xi, 5501_xi, 5505_xi, &
539  5506_xi, 5557_xi, 5561_xi, 5588_xi, 5589_xi, 5596_xi, 5606_xi, 5697_xi, &
540  5705_xi, 162_xi, 163_xi, 166_xi, 168_xi, 171_xi, 172_xi, 173_xi, &
541  177_xi, 181_xi, 362_xi, 363_xi, 367_xi, 369_xi, 375_xi, 378_xi, &
542  382_xi, 383_xi, 386_xi, 570_xi, 571_xi, 574_xi, 576_xi, 579_xi, &
543  580_xi, 581_xi, 585_xi, 589_xi, 758_xi, 759_xi, 763_xi, 765_xi, &
544  769_xi, 774_xi, 775_xi, 778_xi, 962_xi, 963_xi, 966_xi, 968_xi, &
545  971_xi, 972_xi, 973_xi, 977_xi, 981_xi, 1150_xi, 1151_xi, 1155_xi, &
546  1157_xi, 1161_xi, 1166_xi, 1167_xi, 1170_xi, 1354_xi, 1355_xi, 1358_xi, &
547  1360_xi, 1363_xi, 1364_xi, 1365_xi, 1369_xi, 1373_xi, 1542_xi, 1543_xi, &
548  1547_xi, 1549_xi, 1553_xi, 1558_xi, 1559_xi, 1562_xi, 1746_xi, 1747_xi, &
549  1750_xi, 1752_xi, 1755_xi, 1756_xi, 1757_xi, 1761_xi, 1918_xi, 1919_xi, &
550  1923_xi, 1925_xi, 1929_xi, 1934_xi, 1935_xi, 1938_xi, 1988_xi, 1989_xi, &
551  2024_xi, 2025_xi, 2032_xi, 2033_xi, 2036_xi, 2038_xi, 2039_xi, 2048_xi, &
552  2049_xi, 2053_xi, 2054_xi, 2057_xi, 2058_xi, 2061_xi, 2076_xi, 2077_xi, &
553  2091_xi, 2092_xi, 2093_xi, 2095_xi, 2097_xi, 2126_xi, 2127_xi, 2144_xi, &
554  2145_xi, 2149_xi, 2150_xi, 2156_xi, 2198_xi, 2204_xi, 2205_xi, 2207_xi, &
555  2245_xi, 2253_xi, 2254_xi, 2256_xi, 2268_xi, 2269_xi, 2277_xi, 2279_xi, &
556  2280_xi, 2283_xi, 2287_xi, 2298_xi, 2299_xi, 2307_xi, 2308_xi, 2309_xi, &
557  2310_xi, 2333_xi, 2334_xi, 2380_xi, 2381_xi, 2416_xi, 2417_xi, 2424_xi, &
558  2425_xi, 2428_xi, 2430_xi, 2431_xi, 2440_xi, 2441_xi, 2445_xi, 2446_xi, &
559  2449_xi, 2450_xi, 2453_xi, 2468_xi, 2469_xi, 2483_xi, 2484_xi, 2485_xi, &
560  2487_xi, 2489_xi, 2518_xi, 2519_xi, 2536_xi, 2537_xi, 2541_xi, 2542_xi, &
561  2548_xi, 2590_xi, 2596_xi, 2597_xi, 2599_xi, 2637_xi, 2645_xi, 2646_xi, &
562  2648_xi, 2660_xi, 2661_xi, 2669_xi, 2671_xi, 2672_xi, 2675_xi, 2679_xi, &
563  2690_xi, 2691_xi, 2699_xi, 2700_xi, 2701_xi, 2702_xi, 2725_xi, 2726_xi, &
564  2772_xi, 2773_xi, 2808_xi, 2809_xi, 2816_xi, 2817_xi, 2820_xi, 2822_xi, &
565  2823_xi, 2832_xi, 2833_xi, 2837_xi, 2838_xi, 2841_xi, 2842_xi, 2845_xi, &
566  2860_xi, 2861_xi, 2875_xi, 2876_xi, 2877_xi, 2879_xi, 2881_xi, 2910_xi, &
567  2911_xi, 2928_xi, 2929_xi, 2933_xi, 2934_xi, 2940_xi, 2982_xi, 2988_xi, &
568  2989_xi, 2991_xi, 3029_xi, 3037_xi, 3038_xi, 3040_xi, 3052_xi, 3053_xi, &
569  3061_xi, 3063_xi, 3064_xi, 3067_xi, 3071_xi, 3082_xi, 3083_xi, 3091_xi, &
570  3092_xi, 3093_xi, 3094_xi, 3117_xi, 3118_xi, 3164_xi, 3165_xi, 3200_xi, &
571  3201_xi, 3208_xi, 3209_xi, 3212_xi, 3214_xi, 3215_xi, 3224_xi, 3225_xi, &
572  3229_xi, 3230_xi, 3233_xi, 3234_xi, 3237_xi, 3252_xi, 3253_xi, 3267_xi, &
573  3268_xi, 3269_xi, 3271_xi, 3273_xi, 3302_xi, 3303_xi, 3320_xi, 3321_xi, &
574  3325_xi, 3326_xi, 3332_xi, 3374_xi, 3380_xi, 3381_xi, 3383_xi, 3421_xi, &
575  3429_xi, 3430_xi, 3432_xi, 3444_xi, 3445_xi, 3453_xi, 3455_xi, 3456_xi, &
576  3459_xi, 3463_xi, 3474_xi, 3475_xi, 3483_xi, 3484_xi, 3485_xi, 3486_xi, &
577  3509_xi, 3510_xi, 3556_xi, 3557_xi, 3592_xi, 3593_xi, 3600_xi, 3601_xi, &
578  3604_xi, 3606_xi, 3607_xi, 3616_xi, 3617_xi, 3621_xi, 3622_xi, 3625_xi, &
579  3626_xi, 3629_xi, 3644_xi, 3645_xi, 3659_xi, 3660_xi, 3661_xi, 3663_xi, &
580  3665_xi, 3694_xi, 3695_xi, 3712_xi, 3713_xi, 3717_xi, 3718_xi, 3724_xi, &
581  3766_xi, 3772_xi, 3773_xi, 3775_xi, 3813_xi, 3821_xi, 3822_xi, 3824_xi, &
582  3836_xi, 3837_xi, 3845_xi, 3847_xi, 3848_xi, 3851_xi, 3855_xi, 3866_xi, &
583  3867_xi, 3875_xi, 3876_xi, 3877_xi, 3878_xi, 3901_xi, 3902_xi, 3948_xi, &
584  3949_xi, 3984_xi, 3985_xi, 3992_xi, 3993_xi, 3996_xi, 3998_xi, 3999_xi, &
585  4008_xi, 4009_xi, 4013_xi, 4014_xi, 4017_xi, 4018_xi, 4021_xi, 4036_xi, &
586  4037_xi, 4051_xi, 4052_xi, 4054_xi, 4055_xi, 4058_xi, 4090_xi, 4091_xi, &
587  4093_xi, 4108_xi, 4109_xi, 4112_xi, 4113_xi, 4114_xi, 4158_xi, 4164_xi, &
588  4165_xi, 4193_xi, 4199_xi, 4200_xi, 4212_xi, 4213_xi, 4222_xi, 4223_xi, &
589  4225_xi, 4227_xi, 4231_xi, 4242_xi, 4243_xi, 4250_xi, 4251_xi, 4271_xi, &
590  4272_xi, 4274_xi, 4324_xi, 4325_xi, 4360_xi, 4361_xi, 4368_xi, 4369_xi, &
591  4372_xi, 4374_xi, 4375_xi, 4384_xi, 4385_xi, 4389_xi, 4390_xi, 4393_xi, &
592  4394_xi, 4397_xi, 4412_xi, 4413_xi, 4427_xi, 4428_xi, 4430_xi, 4431_xi, &
593  4434_xi, 4466_xi, 4467_xi, 4469_xi, 4484_xi, 4485_xi, 4488_xi, 4489_xi, &
594  4490_xi, 4534_xi, 4540_xi, 4541_xi, 4569_xi, 4575_xi, 4576_xi, 4588_xi, &
595  4589_xi, 4598_xi, 4599_xi, 4601_xi, 4603_xi, 4607_xi, 4618_xi, 4619_xi, &
596  4626_xi, 4627_xi, 4647_xi, 4648_xi, 4650_xi, 4700_xi, 4701_xi, 4736_xi, &
597  4737_xi, 4744_xi, 4745_xi, 4748_xi, 4750_xi, 4751_xi, 4760_xi, 4761_xi, &
598  4765_xi, 4766_xi, 4769_xi, 4770_xi, 4773_xi, 4788_xi, 4789_xi, 4803_xi, &
599  4804_xi, 4806_xi, 4807_xi, 4810_xi, 4842_xi, 4843_xi, 4845_xi, 4860_xi, &
600  4861_xi, 4864_xi, 4865_xi, 4866_xi, 4910_xi, 4916_xi, 4917_xi, 4951_xi, &
601  4952_xi, 4964_xi, 4965_xi, 4974_xi, 4975_xi, 4977_xi, 4979_xi, 4983_xi, &
602  4994_xi, 4995_xi, 5002_xi, 5003_xi, 5023_xi, 5024_xi, 5026_xi, 5076_xi, &
603  5077_xi, 5112_xi, 5113_xi, 5120_xi, 5121_xi, 5124_xi, 5126_xi, 5127_xi, &
604  5136_xi, 5137_xi, 5141_xi, 5142_xi, 5145_xi, 5146_xi, 5149_xi, 5164_xi, &
605  5165_xi, 5179_xi, 5180_xi, 5182_xi, 5183_xi, 5186_xi, 5218_xi, 5219_xi, &
606  5221_xi, 5236_xi, 5237_xi, 5240_xi, 5241_xi, 5242_xi, 5286_xi, 5292_xi, &
607  5293_xi, 5327_xi, 5328_xi, 5340_xi, 5341_xi, 5350_xi, 5351_xi, 5353_xi, &
608  5355_xi, 5359_xi, 5370_xi, 5371_xi, 5378_xi, 5379_xi, 5399_xi, 5400_xi, &
609  5402_xi, 5452_xi, 5453_xi, 5488_xi, 5489_xi, 5496_xi, 5497_xi, 5500_xi, &
610  5502_xi, 5503_xi, 5512_xi, 5513_xi, 5517_xi, 5518_xi, 5521_xi, 5522_xi, &
611  5525_xi, 5540_xi, 5541_xi, 5555_xi, 5556_xi, 5558_xi, 5559_xi, 5562_xi, &
612  5594_xi, 5595_xi, 5597_xi, 5612_xi, 5613_xi, 5616_xi, 5617_xi, 5618_xi, &
613  5662_xi, 5668_xi, 5669_xi, 5703_xi, 5704_xi, 5716_xi, 5717_xi, 5726_xi, &
614  5727_xi, 5729_xi, 5731_xi, 5735_xi, 5746_xi, 5747_xi, 5754_xi, 5755_xi, &
615  5775_xi, 5776_xi, 5778_xi, 5958_xi, 5959_xi, 5962_xi, 5964_xi, 5967_xi, &
616  5968_xi, 5971_xi, 5973_xi, 6154_xi, 6155_xi, 6159_xi, 6161_xi, 6167_xi, &
617  6170_xi, 6172_xi, 6173_xi, 6350_xi, 6351_xi, 6354_xi, 6356_xi, 6359_xi, &
618  6360_xi, 6363_xi, 6530_xi, 6531_xi, 6535_xi, 6537_xi, 6543_xi, 6546_xi, &
619  6548_xi, 6549_xi, 6726_xi, 6727_xi, 6730_xi, 6732_xi, 6735_xi, 6736_xi, &
620  6739_xi, 6906_xi, 6907_xi, 6911_xi, 6913_xi, 6919_xi, 6922_xi, 6924_xi, &
621  6925_xi, 7102_xi, 7103_xi, 7106_xi, 7108_xi, 7111_xi, 7112_xi, 7115_xi, &
622  7282_xi, 7283_xi, 7287_xi, 7289_xi, 7295_xi, 7298_xi, 7300_xi, 7301_xi, &
623  7478_xi, 7479_xi, 7482_xi, 7484_xi, 7487_xi, 7488_xi, 7491_xi, 7646_xi, &
624  7647_xi, 7651_xi, 7653_xi, 7657_xi, 7660_xi, 7661_xi, 130_xi, 161_xi, &
625  169_xi, 170_xi, 336_xi, 361_xi, 366_xi, 384_xi, 538_xi, 569_xi, &
626  577_xi, 578_xi, 736_xi, 757_xi, 762_xi, 776_xi, 930_xi, 961_xi, &
627  969_xi, 970_xi, 1128_xi, 1149_xi, 1154_xi, 1168_xi, 1322_xi, 1353_xi, &
628  1361_xi, 1362_xi, 1520_xi, 1541_xi, 1546_xi, 1560_xi, 1714_xi, 1745_xi, &
629  1753_xi, 1754_xi, 1896_xi, 1917_xi, 1922_xi, 1936_xi, 1985_xi, 2019_xi, &
630  2031_xi, 2035_xi, 2040_xi, 2044_xi, 2052_xi, 2059_xi, 2062_xi, 2071_xi, &
631  2087_xi, 2090_xi, 2094_xi, 2140_xi, 2148_xi, 2153_xi, 2157_xi, 2206_xi, &
632  2257_xi, 2263_xi, 2267_xi, 2284_xi, 2288_xi, 2293_xi, 2295_xi, 2305_xi, &
633  2306_xi, 2377_xi, 2411_xi, 2423_xi, 2427_xi, 2432_xi, 2436_xi, 2444_xi, &
634  2451_xi, 2454_xi, 2463_xi, 2479_xi, 2482_xi, 2486_xi, 2532_xi, 2540_xi, &
635  2545_xi, 2549_xi, 2598_xi, 2649_xi, 2655_xi, 2659_xi, 2676_xi, 2680_xi, &
636  2685_xi, 2687_xi, 2697_xi, 2698_xi, 2769_xi, 2803_xi, 2815_xi, 2819_xi, &
637  2824_xi, 2828_xi, 2836_xi, 2843_xi, 2846_xi, 2855_xi, 2871_xi, 2874_xi, &
638  2878_xi, 2924_xi, 2932_xi, 2937_xi, 2941_xi, 2990_xi, 3041_xi, 3047_xi, &
639  3051_xi, 3068_xi, 3072_xi, 3077_xi, 3079_xi, 3089_xi, 3090_xi, 3161_xi, &
640  3195_xi, 3207_xi, 3211_xi, 3216_xi, 3220_xi, 3228_xi, 3235_xi, 3238_xi, &
641  3247_xi, 3263_xi, 3266_xi, 3270_xi, 3316_xi, 3324_xi, 3329_xi, 3333_xi, &
642  3382_xi, 3433_xi, 3439_xi, 3443_xi, 3460_xi, 3464_xi, 3469_xi, 3471_xi, &
643  3481_xi, 3482_xi, 3553_xi, 3587_xi, 3599_xi, 3603_xi, 3608_xi, 3612_xi, &
644  3620_xi, 3627_xi, 3630_xi, 3639_xi, 3655_xi, 3658_xi, 3662_xi, 3708_xi, &
645  3716_xi, 3721_xi, 3725_xi, 3774_xi, 3825_xi, 3831_xi, 3835_xi, 3852_xi, &
646  3856_xi, 3861_xi, 3863_xi, 3873_xi, 3874_xi, 3945_xi, 3979_xi, 3991_xi, &
647  3995_xi, 4000_xi, 4004_xi, 4012_xi, 4019_xi, 4022_xi, 4031_xi, 4033_xi, &
648  4047_xi, 4050_xi, 4104_xi, 4106_xi, 4115_xi, 4207_xi, 4221_xi, 4228_xi, &
649  4232_xi, 4237_xi, 4249_xi, 4252_xi, 4321_xi, 4355_xi, 4367_xi, 4371_xi, &
650  4376_xi, 4380_xi, 4388_xi, 4395_xi, 4398_xi, 4407_xi, 4409_xi, 4423_xi, &
651  4426_xi, 4480_xi, 4482_xi, 4491_xi, 4583_xi, 4597_xi, 4604_xi, 4608_xi, &
652  4613_xi, 4625_xi, 4628_xi, 4697_xi, 4731_xi, 4743_xi, 4747_xi, 4752_xi, &
653  4756_xi, 4764_xi, 4771_xi, 4774_xi, 4783_xi, 4785_xi, 4799_xi, 4802_xi, &
654  4856_xi, 4858_xi, 4867_xi, 4959_xi, 4973_xi, 4980_xi, 4984_xi, 4989_xi, &
655  5001_xi, 5004_xi, 5073_xi, 5107_xi, 5119_xi, 5123_xi, 5128_xi, 5132_xi, &
656  5140_xi, 5147_xi, 5150_xi, 5159_xi, 5161_xi, 5175_xi, 5178_xi, 5232_xi, &
657  5234_xi, 5243_xi, 5335_xi, 5349_xi, 5356_xi, 5360_xi, 5365_xi, 5377_xi, &
658  5380_xi, 5449_xi, 5483_xi, 5495_xi, 5499_xi, 5504_xi, 5508_xi, 5516_xi, &
659  5523_xi, 5526_xi, 5535_xi, 5537_xi, 5551_xi, 5554_xi, 5608_xi, 5610_xi, &
660  5619_xi, 5711_xi, 5725_xi, 5732_xi, 5736_xi, 5741_xi, 5753_xi, 5756_xi, &
661  5930_xi, 5957_xi, 5965_xi, 5966_xi, 6128_xi, 6153_xi, 6158_xi, 6174_xi, &
662  6322_xi, 6349_xi, 6357_xi, 6358_xi, 6504_xi, 6529_xi, 6534_xi, 6550_xi, &
663  6698_xi, 6725_xi, 6733_xi, 6734_xi, 6880_xi, 6905_xi, 6910_xi, 6926_xi, &
664  7074_xi, 7101_xi, 7109_xi, 7110_xi, 7256_xi, 7281_xi, 7286_xi, 7302_xi, &
665  7450_xi, 7477_xi, 7485_xi, 7486_xi, 7624_xi, 7645_xi, 7650_xi, 7662_xi /)
666  INTEGER, PARAMETER :: num_stripes = 187
667  TYPE(xt_stripe), PARAMETER :: stripes(num_stripes) = (/ &
668  xt_stripe(173, 408, 2), xt_stripe(973, 392, 3), xt_stripe(1985, 4, 2), &
669  xt_stripe(2044, 4, 2), xt_stripe(2049, 3, 1), xt_stripe(2052, 1, 9), &
670  xt_stripe(2062, 131, 2), xt_stripe(2198, 1, 2), xt_stripe(2203, 1, 5), &
671  xt_stripe(2211, 1, 2), xt_stripe(2263, 4, 1), xt_stripe(2267, 1, 3), &
672  xt_stripe(2277, 1, 5), xt_stripe(2283, 1, 2), xt_stripe(2287, 1, 2), &
673  xt_stripe(2293, 2, 2), xt_stripe(2298, 1, 2), xt_stripe(2305, 1, 8), &
674  xt_stripe(2316, 1, 2), xt_stripe(2322, 10, 1), xt_stripe(2332, 1, 3), &
675  xt_stripe(2377, 4, 2), xt_stripe(2436, 4, 2), xt_stripe(2441, 3, 1), &
676  xt_stripe(2444, 1, 9), xt_stripe(2454, 131, 2), xt_stripe(2590, 1, 2), &
677  xt_stripe(2595, 1, 5), xt_stripe(2603, 1, 2), xt_stripe(2655, 4, 1), &
678  xt_stripe(2659, 1, 3), xt_stripe(2669, 1, 5), xt_stripe(2675, 1, 2), &
679  xt_stripe(2679, 1, 2), xt_stripe(2685, 2, 2), xt_stripe(2690, 1, 2), &
680  xt_stripe(2697, 1, 8), xt_stripe(2708, 1, 2), xt_stripe(2714, 10, 1), &
681  xt_stripe(2724, 1, 3), xt_stripe(2769, 4, 2), xt_stripe(2828, 4, 2), &
682  xt_stripe(2833, 3, 1), xt_stripe(2836, 1, 9), xt_stripe(2846, 131, 2), &
683  xt_stripe(2982, 1, 2), xt_stripe(2987, 1, 5), xt_stripe(2995, 1, 2), &
684  xt_stripe(3047, 4, 1), xt_stripe(3051, 1, 3), xt_stripe(3061, 1, 5), &
685  xt_stripe(3067, 1, 2), xt_stripe(3071, 1, 2), xt_stripe(3077, 2, 2), &
686  xt_stripe(3082, 1, 2), xt_stripe(3089, 1, 8), xt_stripe(3100, 1, 2), &
687  xt_stripe(3106, 10, 1), xt_stripe(3116, 1, 3), xt_stripe(3161, 4, 2), &
688  xt_stripe(3220, 4, 2), xt_stripe(3225, 3, 1), xt_stripe(3228, 1, 9), &
689  xt_stripe(3238, 131, 2), xt_stripe(3374, 1, 2), xt_stripe(3379, 1, 5), &
690  xt_stripe(3387, 1, 2), xt_stripe(3439, 4, 1), xt_stripe(3443, 1, 3), &
691  xt_stripe(3453, 1, 5), xt_stripe(3459, 1, 2), xt_stripe(3463, 1, 2), &
692  xt_stripe(3469, 2, 2), xt_stripe(3474, 1, 2), xt_stripe(3481, 1, 8), &
693  xt_stripe(3492, 1, 2), xt_stripe(3498, 10, 1), xt_stripe(3508, 1, 3), &
694  xt_stripe(3553, 4, 2), xt_stripe(3612, 4, 2), xt_stripe(3617, 3, 1), &
695  xt_stripe(3620, 1, 9), xt_stripe(3630, 131, 2), xt_stripe(3766, 1, 2), &
696  xt_stripe(3771, 1, 5), xt_stripe(3779, 1, 2), xt_stripe(3831, 4, 1), &
697  xt_stripe(3835, 1, 3), xt_stripe(3845, 1, 5), xt_stripe(3851, 1, 2), &
698  xt_stripe(3855, 1, 2), xt_stripe(3861, 2, 2), xt_stripe(3866, 1, 2), &
699  xt_stripe(3873, 1, 8), xt_stripe(3884, 1, 2), xt_stripe(3890, 10, 1), &
700  xt_stripe(3900, 1, 3), xt_stripe(3945, 3, 2), xt_stripe(3979, 5, 2), &
701  xt_stripe(3985, 6, 1), xt_stripe(3991, 1, 3), xt_stripe(3995, 2, 1), &
702  xt_stripe(3997, 1, 6), xt_stripe(4031, 2, 2), xt_stripe(4036, 1, 2), &
703  xt_stripe(4047, 3, 1), xt_stripe(4050, 1, 6), xt_stripe(4057, 1, 2), &
704  xt_stripe(4084, 1, 2), xt_stripe(4090, 1, 4), xt_stripe(4102, 2, 4), &
705  xt_stripe(4109, 3, 1), xt_stripe(4112, 1, 4), xt_stripe(4188, 4, 2), &
706  xt_stripe(4193, 6, 1), xt_stripe(4199, 1, 3), xt_stripe(4321, 3, 2), &
707  xt_stripe(4355, 5, 2), xt_stripe(4361, 6, 1), xt_stripe(4367, 1, 3), &
708  xt_stripe(4371, 2, 1), xt_stripe(4373, 1, 6), xt_stripe(4407, 2, 2), &
709  xt_stripe(4412, 1, 2), xt_stripe(4423, 3, 1), xt_stripe(4426, 1, 6), &
710  xt_stripe(4433, 1, 2), xt_stripe(4460, 1, 2), xt_stripe(4466, 1, 4), &
711  xt_stripe(4478, 2, 4), xt_stripe(4485, 3, 1), xt_stripe(4488, 1, 4), &
712  xt_stripe(4564, 4, 2), xt_stripe(4569, 6, 1), xt_stripe(4575, 1, 3), &
713  xt_stripe(4697, 3, 2), xt_stripe(4731, 5, 2), xt_stripe(4737, 6, 1), &
714  xt_stripe(4743, 1, 3), xt_stripe(4747, 2, 1), xt_stripe(4749, 1, 6), &
715  xt_stripe(4783, 2, 2), xt_stripe(4788, 1, 2), xt_stripe(4799, 3, 1), &
716  xt_stripe(4802, 1, 6), xt_stripe(4809, 1, 2), xt_stripe(4836, 1, 2), &
717  xt_stripe(4842, 1, 4), xt_stripe(4854, 2, 4), xt_stripe(4861, 3, 1), &
718  xt_stripe(4864, 1, 4), xt_stripe(4945, 6, 1), xt_stripe(4951, 1, 3), &
719  xt_stripe(5107, 5, 2), xt_stripe(5113, 6, 1), xt_stripe(5119, 1, 3), &
720  xt_stripe(5123, 2, 1), xt_stripe(5125, 1, 6), xt_stripe(5159, 2, 2), &
721  xt_stripe(5164, 1, 2), xt_stripe(5175, 3, 1), xt_stripe(5178, 1, 6), &
722  xt_stripe(5185, 1, 2), xt_stripe(5212, 1, 2), xt_stripe(5218, 1, 4), &
723  xt_stripe(5230, 2, 4), xt_stripe(5237, 3, 1), xt_stripe(5240, 1, 4), &
724  xt_stripe(5321, 6, 1), xt_stripe(5327, 1, 3), xt_stripe(5483, 5, 2), &
725  xt_stripe(5489, 6, 1), xt_stripe(5495, 1, 3), xt_stripe(5499, 2, 1), &
726  xt_stripe(5501, 1, 6), xt_stripe(5535, 2, 2), xt_stripe(5540, 1, 2), &
727  xt_stripe(5551, 3, 1), xt_stripe(5554, 1, 6), xt_stripe(5561, 1, 2), &
728  xt_stripe(5588, 1, 2), xt_stripe(5594, 1, 4), xt_stripe(5606, 2, 4), &
729  xt_stripe(5613, 3, 1), xt_stripe(5616, 1, 4), xt_stripe(5697, 6, 1), &
730  xt_stripe(5703, 1, 3) /)
731  TYPE(xt_idxlist) :: idxlist
732 
733  idxlist = xt_idxvec_new(index_vector)
734  CALL check_idxlist_stripes_pos_ext(idxlist, stripes)
735  CALL xt_idxlist_delete(idxlist)
736  END SUBROUTINE test_idxlist_stripes_pos_ext3
737 
738 #if SIZEOF_XT_INT > 2
739  SUBROUTINE test_idxlist_stripes_pos_ext4
740  INTEGER, PARAMETER :: num_indices = 3
741  INTEGER(xt_int_kind), PARAMETER :: index_vector(num_indices) &
742  = (/ 328669_xi, 30608_xi, 38403_xi /)
743  INTEGER, PARAMETER :: num_stripes = 1
744  TYPE(xt_stripe), PARAMETER :: stripes(num_stripes) = (/ &
745  xt_stripe(30608_xi, 7795_xi, 2)/)
746  TYPE(xt_idxlist) :: idxlist
747 
748  idxlist = xt_idxvec_new(index_vector)
749  CALL check_idxlist_stripes_pos_ext(idxlist, stripes)
750  CALL xt_idxlist_delete(idxlist)
751  END SUBROUTINE test_idxlist_stripes_pos_ext4
752 
753  SUBROUTINE test_idxlist_stripes_pos_ext5
754  INTEGER, PARAMETER :: num_indices = 3
755  INTEGER(xt_int_kind), PARAMETER :: index_vector(num_indices) &
756  = (/ 679605_xi, 726349_xi, 726346_xi /)
757  INTEGER, PARAMETER :: num_stripes = 1
758  TYPE(xt_stripe), PARAMETER :: stripes(num_stripes) = (/ &
759  xt_stripe(679605_xi, 46741_xi, 2)/)
760  TYPE(xt_idxlist) :: idxlist
761 
762  idxlist = xt_idxvec_new(index_vector)
763  CALL check_idxlist_stripes_pos_ext(idxlist, stripes)
764  CALL xt_idxlist_delete(idxlist)
765  END SUBROUTINE test_idxlist_stripes_pos_ext5
766 #endif
767 
768  SUBROUTINE test_idxlist_stripes_pos_ext_randomized1(full_random)
769  LOGICAL, INTENT(in) :: full_random
770  INTEGER, PARAMETER :: num_iterations=128, &
771  max_num_indices=1024, max_index=1024
772 
773  INTEGER :: i, iteration, num_indices
774  INTEGER(xt_int_kind), ALLOCATABLE :: indices(:)
775  REAL, ALLOCATABLE :: rvals(:)
776  TYPE(xt_idxlist) :: idxlist
777  TYPE(xt_stripe), ALLOCATABLE :: stripes(:)
778  TYPE(xt_stripe) :: stripes_dummy(1)
779 
780  CALL init_fortran_random(full_random)
781  ALLOCATE(indices(max_num_indices), rvals(max_num_indices))
782  DO iteration = 1, num_iterations
783  CALL random_number(rvals(1))
784  num_indices = nint(rvals(1) * real(max_num_indices))
785 
786  CALL random_number(rvals(1:num_indices))
787  DO i = 1, num_indices
788  indices(i) = nint(rvals(i)*real((2*max_index)-max_index), xt_int_kind)
789  END DO
790  idxlist = xt_idxvec_new(indices(1:num_indices))
791 
792  CALL xt_idxlist_get_index_stripes(idxlist, stripes)
793  IF (ALLOCATED(stripes) .EQV. num_indices == 0) &
794  CALL test_abort("get index stripes returned values for empty list", &
795  filename, __line__)
796  IF (num_indices > 0) THEN
797  CALL check_idxlist_stripes_pos_ext(idxlist, stripes)
798  ELSE
799  CALL check_idxlist_stripes_pos_ext(idxlist, stripes_dummy(1:0))
800  END IF
801 
802  CALL xt_idxlist_delete(idxlist)
803  END DO
804  END SUBROUTINE test_idxlist_stripes_pos_ext_randomized1
805 
806  SUBROUTINE check_idxlist_stripes_pos_ext(idxlist, stripes)
807  TYPE(xt_idxlist), INTENT(in) :: idxlist
808  TYPE(xt_stripe), INTENT(in) :: stripes(:)
809 
810  TYPE(xt_pos_ext), ALLOCATABLE :: pos_ext(:)
811  INTEGER :: num_stripes, num_ext, num_unmatched
812  INTEGER :: abs_pos_ext_size, jsign, i, j, k, send_pos
813  INTEGER(xt_int_kind) :: intersection_index, orig_index
814  LOGICAL, PARAMETER :: single_match_only = .true.
815  LOGICAL :: unmatched_in_intersection, unmatched_in_idxlist
816  TYPE(xt_idxlist) :: intersection
817  num_stripes = SIZE(stripes)
818 
820  idxlist, num_stripes, stripes, num_ext, pos_ext, single_match_only)
821 
822  ! testing of results
823  IF (num_unmatched /= 0) &
824  CALL test_abort("error in xt_idxlist_get_pos_exts_of_index_stripes", &
825  filename, __line__)
826  intersection = xt_idxvec_from_stripes_new(stripes)
827  k = 0
828  DO i = 1, num_ext
829  abs_pos_ext_size = int(abs(pos_ext(i)%size))
830  jsign = merge(1, -1, pos_ext(i)%size >= 0)
831  DO j = 0, abs_pos_ext_size-1
832  unmatched_in_intersection &
833  = xt_idxlist_get_index_at_position(intersection, k, &
834  intersection_index)
835  send_pos = pos_ext(i)%start + jsign * j
836  unmatched_in_idxlist &
837  = xt_idxlist_get_index_at_position(idxlist, send_pos, orig_index)
838  IF (unmatched_in_intersection .OR. unmatched_in_idxlist &
839  .OR. intersection_index /= orig_index) THEN
840  WRITE (0, '(4(a,i0))') "intersection pos ", k, &
841  " index ", intersection_index, &
842  " orig pos ", send_pos, &
843  " index ", orig_index
844  CALL test_abort("error in xt_idxlist_get_pos_exts_of_index_stripes", &
845  filename, __line__)
846  END IF
847  k = k + 1
848  END DO
849  END DO
850  CALL xt_idxlist_delete(intersection)
851  END SUBROUTINE check_idxlist_stripes_pos_ext
852 
853  SUBROUTINE test_get_pos(stripes, pos)
854  TYPE(xt_stripe), INTENT(in) :: stripes(:)
855  INTEGER, INTENT(in) :: pos(:)
856  INTEGER(xt_int_kind), PARAMETER :: dummy = 1_xi
857  INTEGER(xt_int_kind) :: ref_sel_idx(SIZE(pos)), sel_idx(SIZE(pos))
858  INTEGER(xt_int_kind), PARAMETER :: undef_idx = -huge(dummy)
859  INTEGER :: num_pos, ip, p, ref_undef_count, undef_count
860  TYPE(xt_idxlist) :: idxlist
861  idxlist = xt_idxstripes_new(stripes)
862  num_pos = SIZE(pos)
863  ref_undef_count = 0
864  DO ip = 1, num_pos
865  p = pos(ip)
866  IF (xt_idxlist_get_index_at_position(idxlist, p, ref_sel_idx(ip))) THEN
867  ref_sel_idx(ip) = undef_idx
868  ref_undef_count = ref_undef_count + 1
869  END IF
870  END DO
871  undef_count = xt_idxlist_get_indices_at_positions(idxlist, pos, sel_idx, &
872  undef_idx)
873  IF (undef_count /= ref_undef_count) &
874  CALL test_abort("inequal undef count!", filename, __line__)
875  IF (any(sel_idx /= ref_sel_idx)) &
876  CALL test_abort("incorrect index returned for position!", &
877  filename, __line__)
878  CALL xt_idxlist_delete(idxlist)
879  END SUBROUTINE test_get_pos
880 
881  SUBROUTINE test_get_pos1
882  TYPE(xt_stripe), PARAMETER :: stripes(3) = (/ xt_stripe(0, 1, 5), &
883  xt_stripe(10, 1, 5), xt_stripe(20, -1, 5) /)
884  INTEGER, PARAMETER :: pos(13) = &
885  (/ 0, 2, 7, 9, 11, &
886  & 100, 11, 200, 9, 300, &
887  & 18, 400, 5 /)
888  call test_get_pos(stripes, pos)
889  END SUBROUTINE test_get_pos1
890 
891  SUBROUTINE test_get_pos2
892  TYPE(xt_stripe), PARAMETER :: stripes(4) = (/ xt_stripe(0, 1, 3), &
893  xt_stripe(10, 1, 2), xt_stripe(20, -1, 6), xt_stripe(30, -1, 7) /)
894  INTEGER, PARAMETER :: pos(19) = &
895  (/ -1, 0, 1, 2, 3, 4, 23, 5, 6, 7, &
896  & 8, 9, 10, 11, 12, 0, 2, 100, 2000 /)
897  call test_get_pos(stripes, pos)
898  END SUBROUTINE test_get_pos2
899 
900  SUBROUTINE test_get_pos3
901  TYPE(xt_stripe), PARAMETER :: stripes(4) = (/ xt_stripe(0, 1, 3), &
902  xt_stripe(10, 1, 2), xt_stripe(20, -1, 6), xt_stripe(30, -1, 7) /)
903  INTEGER, PARAMETER :: pos(13) = &
904  (/ 4, 7, 2, 5, 9, 0, 10, 6, 11, 8, &
905  & 12, 1, 3 /)
906  call test_get_pos(stripes, pos)
907  END SUBROUTINE test_get_pos3
908 
909  SUBROUTINE test_get_pos4
910  TYPE(xt_stripe), PARAMETER :: stripes(3) = (/ xt_stripe(0, 1, 5), &
911  xt_stripe(10, 1, 5), xt_stripe(20, -1, 5) /)
912  INTEGER, PARAMETER :: pos(7) = &
913  (/ -10, 200, 700, 90, 90, 18, 141 /)
914  CALL test_get_pos(stripes, pos)
915  END SUBROUTINE test_get_pos4
916 
917  SUBROUTINE test_stripe_overlap
918  TYPE(xt_stripe), PARAMETER :: stripes(2) = (/ xt_stripe(0, 1, 5), &
919  xt_stripe(1, 1, 5) /)
920 #ifndef __G95__
921  INTEGER(xi) :: i, j
922  INTEGER(xt_int_kind), PARAMETER :: ref_indices(10) &
923  = (/ ((i + j, i=0,4), j = 0, 1) /)
924 #else
925  INTEGER :: i, j
926  INTEGER(xt_int_kind), PARAMETER :: ref_indices(10) &
927  = (/ ((int(i + j, xi), i=0,4), j = 0, 1) /)
928 #endif
929  CALL stripe_test_general(stripes, ref_indices)
930  END SUBROUTINE test_stripe_overlap
931 
932  SUBROUTINE test_stripe_bb(stripes, global_size, global_start_index, bounds_ref)
933  TYPE(xt_stripe), INTENT(in) :: stripes(:)
934  INTEGER(xt_int_kind), INTENT(in) :: global_size(:), global_start_index
935  TYPE(xt_bounds), INTENT(in) :: bounds_ref(:)
936 
937  TYPE(xt_bounds) :: bounds(SIZE(global_size))
938  TYPE(xt_idxlist) :: idxstripes
939 
940  IF (SIZE(global_size) /= SIZE(bounds_ref)) &
941  CALL test_abort("size mismatch for bounding-box", filename, __line__)
942  idxstripes = xt_idxstripes_new(stripes, SIZE(stripes))
943 
944  bounds = xt_idxlist_get_bounding_box(idxstripes, global_size, &
945  global_start_index)
946  IF (any(bounds /= bounds_ref)) &
947  CALL test_abort("boundary box doesn't match reference", &
948  filename, __line__)
949  CALL xt_idxlist_delete(idxstripes)
950  END SUBROUTINE test_stripe_bb
951 
952  SUBROUTINE test_stripe_bb1
953  TYPE(xt_stripe), PARAMETER :: stripes(1) = (/ xt_stripe(-1, -1, -1) /)
954  INTEGER(xt_int_kind), PARAMETER :: global_size(3) = 4_xi, &
955  global_start_index = 0
956  TYPE(xt_bounds), PARAMETER :: bounds_ref(3) = xt_bounds(0, 0)
957  CALL test_stripe_bb(stripes(1:0), global_size, global_start_index, bounds_ref)
958  END SUBROUTINE test_stripe_bb1
959 
960  SUBROUTINE test_stripe_bb2
961  TYPE(xt_stripe), PARAMETER :: stripes(3) = (/ xt_stripe(47, -12, 2), &
962  xt_stripe(32, 12, 2), xt_stripe(36, 12, 2) /)
963  INTEGER(xt_int_kind), PARAMETER :: global_size(3) = (/ 5_xi, 4_xi, 3_xi /), &
964  global_start_index = 1
965  TYPE(xt_bounds), PARAMETER :: bounds_ref(3) = (/ xt_bounds(2, 2), &
966  xt_bounds(2, 2), xt_bounds(1, 2) /)
967  CALL test_stripe_bb(stripes, global_size, global_start_index, bounds_ref)
968  END SUBROUTINE test_stripe_bb2
969 
970  SUBROUTINE do_tests(idxlist, ref_indices)
971  TYPE(xt_idxlist), INTENT(in) :: idxlist
972  INTEGER(xt_int_kind), INTENT(in) :: ref_indices(:)
973 
974  TYPE(xt_stripe), ALLOCATABLE :: stripes(:)
975  TYPE(xt_stripe), PARAMETER :: dummy(1) = (/ xt_stripe(0,0,0) /)
976  INTEGER :: num_stripes
977  TYPE(xt_idxlist) :: temp_idxlist, idxlist_copy
978 
979  CALL check_idxlist(idxlist, ref_indices)
980  CALL xt_idxlist_get_index_stripes(idxlist, stripes)
981  IF (ALLOCATED(stripes)) THEN
982  num_stripes = SIZE(stripes)
983  temp_idxlist = xt_idxvec_from_stripes_new(stripes, num_stripes)
984  ELSE
985  num_stripes = 0
986  temp_idxlist = xt_idxvec_from_stripes_new(dummy, num_stripes)
987  END IF
988  CALL check_idxlist(temp_idxlist, ref_indices)
989 
990  CALL xt_idxlist_delete(temp_idxlist)
991 
992  IF (ALLOCATED(stripes)) DEALLOCATE(stripes)
993 
994  ! test packing and unpacking
995  idxlist_copy = idxlist_pack_unpack_copy(idxlist)
996 
997  ! check copy
998  CALL check_idxlist(idxlist_copy, ref_indices)
999 
1000  CALL xt_idxlist_delete(idxlist_copy)
1001 
1002  ! test copying
1003  idxlist_copy = xt_idxlist_copy(idxlist)
1004 
1005  ! check copy
1006  CALL check_idxlist(idxlist_copy, ref_indices)
1007 
1008  ! clean up
1009  CALL xt_idxlist_delete(idxlist_copy)
1010  END SUBROUTINE do_tests
1011 
1012  SUBROUTINE check_pos_ext(stripes, search_stripes, ref_pos_ext, &
1013  single_match_only, ref_unmatched, test_desc)
1014  TYPE(xt_stripe), INTENT(in) :: stripes(:), search_stripes(:)
1015  TYPE(xt_pos_ext), intent(in) :: ref_pos_ext(:)
1016  LOGICAL, INTENT(in) :: single_match_only
1017  INTEGER, INTENT(in) :: ref_unmatched
1018  CHARACTER(len=*) :: test_desc
1019 
1020  INTEGER :: num_search_stripes, num_ref_pos_ext, num_ext, &
1021  unmatched
1022  TYPE(xt_idxlist) :: idxstripes
1023  TYPE(xt_pos_ext), ALLOCATABLE :: pos_ext(:)
1024 
1025  num_search_stripes = SIZE(search_stripes)
1026  num_ref_pos_ext = SIZE(ref_pos_ext)
1027 
1028  idxstripes = xt_idxstripes_new(stripes)
1029  unmatched = xt_idxlist_get_pos_exts_of_index_stripes(idxstripes, &
1030  num_search_stripes, search_stripes, &
1031  num_ext, pos_ext, single_match_only)
1032  IF (unmatched /= ref_unmatched) &
1033  CALL test_abort("error in number of unmatched indices for " &
1034  // test_desc, filename, __line__)
1035  IF (num_ext < 0 .OR. num_ext /= num_ref_pos_ext) &
1036  CALL test_abort("error finding " // test_desc, filename, __line__)
1037  IF (any(pos_ext /= ref_pos_ext)) &
1038  CALL test_abort("incorrect position extent length found in "&
1039  // test_desc, filename, __line__)
1040  DEALLOCATE(pos_ext)
1041  CALL xt_idxlist_delete(idxstripes)
1042  END SUBROUTINE check_pos_ext
1043 
1044  SUBROUTINE check_pos_ext1
1045  INTEGER, PARAMETER :: num_stripes = 1, num_ref_pos_ext = 1, &
1046  num_ref_unmatched = 0
1047 
1048  TYPE(Xt_stripe), PARAMETER :: stripes(num_stripes) &
1049  = (/ xt_stripe(1_xi, 1_xi, 10) /), &
1050  search_stripes(1) = (/ xt_stripe(10_xi, -1_xi, 5) /)
1051 
1052  TYPE(xt_pos_ext), PARAMETER :: ref_pos_ext(num_ref_pos_ext) &
1053  = (/ xt_pos_ext(9, -5) /)
1054 
1055  CALL check_pos_ext(stripes, search_stripes, ref_pos_ext, .true., &
1056  num_ref_unmatched, "simple inverted stripe")
1057  END SUBROUTINE check_pos_ext1
1058 
1059  SUBROUTINE check_pos_ext2
1060  INTEGER, PARAMETER :: num_stripes = 1, num_ref_pos_ext = 1, &
1061  num_ref_unmatched = 5
1062 
1063  TYPE(Xt_stripe), PARAMETER :: stripes(num_stripes) &
1064  = (/ xt_stripe(1_xi, 1_xi, 10) /), &
1065  search_stripes(2) = xt_stripe(10_xi, -1_xi, 5)
1066 
1067  TYPE(xt_pos_ext), PARAMETER :: ref_pos_ext(num_ref_pos_ext) &
1068  = (/ xt_pos_ext(9, -5) /)
1069 
1070  CALL check_pos_ext(stripes, search_stripes, ref_pos_ext, .true., &
1071  num_ref_unmatched, "simple inverted stripe")
1072  END SUBROUTINE check_pos_ext2
1073 
1074  SUBROUTINE check_pos_ext3
1075  INTEGER, PARAMETER :: num_stripes = 2, num_ref_pos_ext = 1, &
1076  num_ref_unmatched = 4
1077 
1078  TYPE(Xt_stripe), PARAMETER :: stripes(num_stripes) &
1079  = (/ xt_stripe(1_xi, 1_xi, 10), xt_stripe(15_xi, 1_xi, 10) /), &
1080  search_stripes(1) = xt_stripe(10_xi, 1_xi, 6)
1081 
1082  TYPE(xt_pos_ext), PARAMETER :: ref_pos_ext(num_ref_pos_ext) &
1083  = (/ xt_pos_ext(9, 2) /)
1084 
1085  CALL check_pos_ext(stripes, search_stripes, ref_pos_ext, .true., &
1086  num_ref_unmatched, "search inc stripe over inc gap")
1087  END SUBROUTINE check_pos_ext3
1088 
1089  SUBROUTINE check_pos_ext4
1090  INTEGER, PARAMETER :: num_stripes = 2, num_ref_pos_ext = 1, &
1091  num_ref_unmatched = 4
1092 
1093  TYPE(Xt_stripe), PARAMETER :: stripes(num_stripes) &
1094  = (/ xt_stripe(25_xi, -1_xi, 11), xt_stripe(10_xi, -1_xi, 10) /), &
1095  search_stripes(1) = xt_stripe(10_xi, 1_xi, 6)
1096 
1097  TYPE(xt_pos_ext), PARAMETER :: ref_pos_ext(num_ref_pos_ext) &
1098  = (/ xt_pos_ext(11, -2) /)
1099 
1100  CALL check_pos_ext(stripes, search_stripes, ref_pos_ext, .true., &
1101  num_ref_unmatched, "search inc stripe over dec gap")
1102  END SUBROUTINE check_pos_ext4
1103 
1104  SUBROUTINE check_pos_ext5
1105  INTEGER, PARAMETER :: num_stripes = 2, num_ref_pos_ext = 1, &
1106  num_ref_unmatched = 4
1107 
1108  TYPE(Xt_stripe), PARAMETER :: stripes(num_stripes) &
1109  = (/ xt_stripe(25_xi, -1_xi, 11), xt_stripe(10_xi, -1_xi, 10) /), &
1110  search_stripes(1) = xt_stripe(15_xi, -1_xi, 6)
1111 
1112  TYPE(xt_pos_ext), PARAMETER :: ref_pos_ext(num_ref_pos_ext) &
1113  = (/ xt_pos_ext(10, 2) /)
1114 
1115  CALL check_pos_ext(stripes, search_stripes, ref_pos_ext, .true., &
1116  num_ref_unmatched, "search dec stripe over dec gap")
1117  END SUBROUTINE check_pos_ext5
1118 
1119  SUBROUTINE check_pos_ext6
1120  INTEGER, PARAMETER :: num_stripes = 2, num_ref_pos_ext = 1, &
1121  num_ref_unmatched = 4
1122 
1123  TYPE(Xt_stripe), PARAMETER :: stripes(num_stripes) &
1124  = (/ xt_stripe(1_xi, 1_xi, 10), xt_stripe(15_xi, 1_xi, 10) /), &
1125  search_stripes(1) = xt_stripe(15_xi, -1_xi, 6)
1126 
1127  TYPE(xt_pos_ext), PARAMETER :: ref_pos_ext(num_ref_pos_ext) &
1128  = (/ xt_pos_ext(10, -2) /)
1129 
1130  CALL check_pos_ext(stripes, search_stripes, ref_pos_ext, .true., &
1131  num_ref_unmatched, "search dec stripe over inc gap")
1132  END SUBROUTINE check_pos_ext6
1133 
1134  SUBROUTINE check_pos_ext7
1135  INTEGER, PARAMETER :: num_stripes = 3, num_ref_pos_ext = 1, &
1136  num_ref_unmatched = 8
1137 
1138  TYPE(Xt_stripe), PARAMETER :: stripes(num_stripes) &
1139  = (/ xt_stripe(1_xi, 1_xi, 10), xt_stripe(15_xi, 1_xi, 10), &
1140  & xt_stripe(29_xi, 1_xi, 10) /), &
1141  search_stripes(1) = xt_stripe(32_xi, -1_xi, 30)
1142 
1143  TYPE(xt_pos_ext), PARAMETER :: ref_pos_ext(num_ref_pos_ext) &
1144  = (/ xt_pos_ext(23, -22) /)
1145 
1146  CALL check_pos_ext(stripes, search_stripes, ref_pos_ext, .true., &
1147  num_ref_unmatched, "search dec stripe over 2 inc gap")
1148  END SUBROUTINE check_pos_ext7
1149 
1150  SUBROUTINE check_pos_ext8
1151  INTEGER, PARAMETER :: num_stripes = 5, num_ref_pos_ext = 5, &
1152  num_ref_unmatched = 0
1153 
1154  TYPE(Xt_stripe), PARAMETER :: stripes(num_stripes) &
1155  = (/ xt_stripe(1_xi, 1_xi, 10), xt_stripe(15_xi, 1_xi, 10), &
1156  & xt_stripe(29_xi, 1_xi, 10), xt_stripe(14_xi, -1_xi, 4), &
1157  & xt_stripe(28_xi, -1_xi, 4) /), &
1158  search_stripes(1) = xt_stripe(32_xi, -1_xi, 30)
1159 
1160  TYPE(xt_pos_ext), PARAMETER :: ref_pos_ext(num_ref_pos_ext) &
1161  = (/ xt_pos_ext(23, -4), xt_pos_ext(34, 4), xt_pos_ext(19, -10), &
1162  & xt_pos_ext(30, 4), xt_pos_ext(9, -8) /)
1163 
1164  CALL check_pos_ext(stripes, search_stripes, ref_pos_ext, .true., &
1165  num_ref_unmatched, "search dec stripe over jumbled stripes")
1166  END SUBROUTINE check_pos_ext8
1167 
1168 END PROGRAM test_idxstripes_f
1169 !
1170 ! Local Variables:
1171 ! f90-continuation-indent: 5
1172 ! coding: utf-8
1173 ! indent-tabs-mode: nil
1174 ! show-trailing-whitespace: t
1175 ! require-trailing-newline: t
1176 ! End:
1177 !
Definition: yaxt.f90:49
void xt_initialize(MPI_Comm default_comm)
Definition: xt_init.c:70
void xt_finalize(void)
Definition: xt_init.c:89
int xt_idxlist_get_num_indices(Xt_idxlist idxlist)
Definition: xt_idxlist.c:98
int xt_idxlist_get_index_at_position(Xt_idxlist idxlist, int position, Xt_int *index)
Definition: xt_idxlist.c:158
int xt_idxlist_get_indices_at_positions(Xt_idxlist idxlist, const int *positions, int num_pos, Xt_int *indices, Xt_int undef_idx)
Definition: xt_idxlist.c:165
void xt_idxlist_get_index_stripes(Xt_idxlist idxlist, struct Xt_stripe **stripes, int *num_stripes)
Definition: xt_idxlist.c:118
void xt_idxlist_get_bounding_box(Xt_idxlist idxlist, unsigned ndim, const Xt_int global_size[ndim], Xt_int global_start_index, struct Xt_bounds bounds[ndim])
Definition: xt_idxlist.c:332
int xt_idxlist_get_pos_exts_of_index_stripes(Xt_idxlist idxlist, int num_stripes, const struct Xt_stripe stripes[num_stripes], int *num_ext, struct Xt_pos_ext **pos_ext, int single_match_only)
Definition: xt_idxlist.c:237
Xt_idxlist xt_idxlist_get_intersection(Xt_idxlist idxlist_src, Xt_idxlist idxlist_dst)
Xt_idxlist xt_idxlist_copy(Xt_idxlist idxlist)
Definition: xt_idxlist.c:93
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition: xt_idxlist.c:74
Xt_idxlist xt_idxstripes_from_idxlist_new(Xt_idxlist idxlist_src)
Xt_idxlist xt_idxstripes_new(struct Xt_stripe const *stripes, int num_stripes)
Xt_idxlist xt_idxvec_from_stripes_new(const struct Xt_stripe *stripes, int num_stripes)
Xt_idxlist xt_idxvec_new(const Xt_int *idxlist, int num_indices)
Definition: xt_idxvec.c:163