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