1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47#include "fc_feature_defs.inc"
48PROGRAM test_idxvec
49 USE mpi
58 USE ftest_common, ONLY: init_mpi, finish_mpi, test_abort
59 USE test_idxlist_utils, ONLY: check_idxlist, test_err_count, check_stripes, &
60 check_offsets, idxlist_pack_unpack_copy
61 IMPLICIT NONE
62 INTEGER, PARAMETER :: xi = xt_int_kind
63 INTEGER(xt_int_kind), PARAMETER :: index_vector(7) &
64 = (/ 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, 7_xi /)
65 CHARACTER(len=*), PARAMETER :: filename = 'test_idxvec_f.f90'
66
67 CALL init_mpi
69
70 CALL test_idxvec_pack_unpack
71 CALL test_copying
72 CALL test_repeated_equal_indices
73 CALL test_positions
74 CALL test_intersection_surjective
75 CALL test_intersection_partial
76 CALL test_intersection_inverse_partial
77 CALL test_intersection_unsort_partial
78 CALL test_intersection_unsort_inverse_partial
79 CALL test_stripes1
80 CALL test_stripes2
81 CALL test_stripes3
82 CALL test_stripes4
83 CALL test_stripes5
84 CALL test_stripes6
85 CALL test_stripes7
86 CALL test_get_indices_at_positions1
87 CALL test_get_indices_at_positions2
88 CALL test_get_indices_at_positions3
89 CALL test_get_positions_of_indices
90 CALL test_bounding_box1
91 CALL test_bounding_box2
92 CALL test_bounding_box3
93
94 IF (test_err_count() /= 0) &
95 CALL test_abort("non-zero error count!", filename, __line__)
97 CALL finish_mpi
98CONTAINS
99 SUBROUTINE test_idxvec_pack_unpack
100 TYPE(xt_idxlist) :: idxvector, idxvector_copy, intersection
101 TYPE(xt_stripe),
PARAMETER :: ref_stripes(1) = (/
xt_stripe(1, 1, 7) /)
102 CALL setup_idxvec(idxvector, index_vector)
103
104 idxvector_copy = idxlist_pack_unpack_copy(idxvector)
105
106 CALL check_idxlist(idxvector_copy, index_vector)
107
109
110 CALL check_idxlist(intersection, index_vector)
111
112 CALL compare_stripes(idxvector, ref_stripes)
113
117
118 END SUBROUTINE test_idxvec_pack_unpack
119
120 SUBROUTINE test_copying
121 TYPE(xt_idxlist) :: idxvector, idxvector_copy
122 CALL setup_idxvec(idxvector, index_vector)
124 CALL check_idxlist(idxvector_copy, index_vector)
127 END SUBROUTINE test_copying
128
129 SUBROUTINE test_repeated_equal_indices
130 INTEGER(xt_int_kind), PARAMETER :: index_vector(8) &
131 = (/ 1_xi, 2_xi, 3_xi, 7_xi, 5_xi, 6_xi, 7_xi, 7_xi /)
132 TYPE(xt_idxlist) :: idxvector
133 CALL setup_idxvec(idxvector, index_vector)
135 END SUBROUTINE test_repeated_equal_indices
136
137 SUBROUTINE test_positions
138 LOGICAL, PARAMETER :: single_match_only = .true.
139 INTEGER(xt_int_kind), PARAMETER :: index_vector(20) &
140 = (/ 10_xi, 15_xi, 14_xi, 13_xi, 12_xi, &
141 & 15_xi, 10_xi, 11_xi, 12_xi, 13_xi, &
142 & 23_xi, 18_xi, 19_xi, 20_xi, 21_xi, &
143 & 31_xi, 26_xi, 27_xi, 28_xi, 29_xi /), &
144 intersection_vector(13) &
145 = (/ 12_xi, 12_xi, 13_xi, 13_xi, 14_xi, &
146 & 15_xi, 15_xi, 20_xi, 21_xi, 23_xi, &
147 & 28_xi, 29_xi, 31_xi /)
148 INTEGER :: intersection_pos(SIZE(intersection_vector))
149 INTEGER, PARAMETER :: ref_intersection_pos(SIZE(intersection_vector)) &
150 = (/ 4, 8, 3, 9, 2, 1, 5, 13, 14, 10, 18, 19, 15 /)
151 TYPE(xt_idxlist) :: idxvector
152 INTEGER :: notfound
153 CALL setup_idxvec(idxvector, index_vector)
155 intersection_vector, intersection_pos, single_match_only)
156 IF (notfound /= 0) &
157 CALL test_abort('expected indices not found!', filename, __line__)
158 CALL check_offsets(intersection_pos, ref_intersection_pos)
160 END SUBROUTINE test_positions
161
162 SUBROUTINE test_intersection(index_vector_a, index_vector_b, &
163 ref_intersection_indices)
164 INTEGER(xt_int_kind), INTENT(in) :: index_vector_a(:), index_vector_b(:), &
165 ref_intersection_indices(:)
166
167
168 TYPE(xt_idxlist) :: idxvector1, idxvector2, intersection
169 CALL setup_idxvec(idxvector1, index_vector_a)
170 CALL setup_idxvec(idxvector2, index_vector_b)
172 CALL check_idxlist(intersection, ref_intersection_indices)
176 END SUBROUTINE test_intersection
177
178 SUBROUTINE test_intersection_surjective
179 INTEGER(xt_int_kind), PARAMETER :: index_vector(3, 2) &
180 = reshape((/ 1_xi, 2_xi, 3_xi, 1_xi, 2_xi, 3_xi /), &
181 & shape(index_vector)), &
182 ref_intersection_indices(3) = (/ 1_xi, 2_xi, 3_xi /)
183 CALL test_intersection(index_vector(:, 1), index_vector(:, 2), &
184 ref_intersection_indices)
185 END SUBROUTINE test_intersection_surjective
186
187 SUBROUTINE test_intersection_partial
188 INTEGER(xt_int_kind), PARAMETER :: index_vector(3, 2) &
189 = reshape((/ 1_xi, 2_xi, 3_xi, 2_xi, 3_xi, 4_xi /), &
190 & shape(index_vector)), &
191 ref_intersection_indices(2) = (/ 2_xi, 3_xi /)
192 CALL test_intersection(index_vector(:, 1), index_vector(:, 2), &
193 ref_intersection_indices)
194 END SUBROUTINE test_intersection_partial
195
196 SUBROUTINE test_intersection_inverse_partial
197 INTEGER(xt_int_kind), PARAMETER :: index_vector(3, 2) &
198 = reshape((/ 2_xi, 3_xi, 4_xi, 1_xi, 2_xi, 3_xi /), &
199 & shape(index_vector)), &
200 ref_intersection_indices(2) = (/ 2_xi, 3_xi /)
201 CALL test_intersection(index_vector(:, 1), index_vector(:, 2), &
202 ref_intersection_indices)
203 END SUBROUTINE test_intersection_inverse_partial
204
205 SUBROUTINE test_intersection_unsort_partial
206 INTEGER(xt_int_kind), PARAMETER :: index_vector(3, 2) &
207 = reshape((/ 4_xi, 2_xi, 3_xi, 3_xi, 1_xi, 2_xi /), &
208 & shape(index_vector)), &
209 ref_intersection_indices(2) = (/ 2_xi, 3_xi /)
210 CALL test_intersection(index_vector(:, 1), index_vector(:, 2), &
211 ref_intersection_indices)
212 END SUBROUTINE test_intersection_unsort_partial
213
214 SUBROUTINE test_intersection_unsort_inverse_partial
215 INTEGER(xt_int_kind), PARAMETER :: index_vector(3, 2) &
216 = reshape((/ 3_xi, 1_xi, 2_xi, 4_xi, 2_xi, 3_xi /), &
217 & shape(index_vector)), &
218 ref_intersection_indices(2) = (/ 2_xi, 3_xi /)
219 CALL test_intersection(index_vector(:, 1), index_vector(:, 2), &
220 ref_intersection_indices)
221 END SUBROUTINE test_intersection_unsort_inverse_partial
222
223 SUBROUTINE test_idxvec_from_stripes(stripes, ref_indices)
224 TYPE(xt_stripe), INTENT(in) :: stripes(:)
225 INTEGER(xt_int_kind), INTENT(in) :: ref_indices(:)
226
227 TYPE(xt_idxlist) :: idxvec
229 CALL check_idxlist(idxvec, ref_indices)
231 END SUBROUTINE test_idxvec_from_stripes
232
233 SUBROUTINE test_stripes1
234 TYPE(xt_stripe), PARAMETER :: stripes(2) = &
236 INTEGER(xt_int_kind), PARAMETER :: ref_indices(10) &
237 = (/ 5_xi, 6_xi, 7_xi, 8_xi, 9_xi, 4_xi, 3_xi, 2_xi, 1_xi, 0_xi /)
238 CALL test_idxvec_from_stripes(stripes, ref_indices)
239 END SUBROUTINE test_stripes1
240
241 SUBROUTINE test_stripes2
242 TYPE(xt_stripe), PARAMETER :: stripes(3) &
244 INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
245 = (/ 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, &
246 & 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, &
247 & 4_xi, 5_xi, 6_xi, 7_xi, 8_xi /)
248 CALL test_idxvec_from_stripes(stripes, ref_indices)
249 END SUBROUTINE test_stripes2
250
251 SUBROUTINE test_stripes3
252 TYPE(xt_stripe), PARAMETER :: stripes(3) &
254 INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
255 = (/ 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, &
256 & 0_xi, 1_xi, 2_xi, 3_xi, 4_xi, &
257 & 4_xi, 5_xi, 6_xi, 7_xi, 8_xi /)
258 CALL test_idxvec_from_stripes(stripes, ref_indices)
259 END SUBROUTINE test_stripes3
260
261 SUBROUTINE test_stripes4
262 TYPE(xt_stripe), PARAMETER :: stripes(3) &
264 INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
265 = (/ 2_xi, 3_xi, 4_xi, 5_xi, 6_xi, &
266 & 4_xi, 3_xi, 2_xi, 1_xi, 0_xi, &
267 & 4_xi, 5_xi, 6_xi, 7_xi, 8_xi /)
268 CALL test_idxvec_from_stripes(stripes, ref_indices)
269 END SUBROUTINE test_stripes4
270
271 SUBROUTINE test_stripes5
272 TYPE(xt_stripe), PARAMETER :: stripes(3) &
274 INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
275 = (/ 0_xi, 3_xi, 6_xi, 9_xi, 12_xi, &
276 & 1_xi, 4_xi, 7_xi, 10_xi, 13_xi, &
277 & 14_xi, 11_xi, 8_xi, 5_xi, 2_xi /)
278 CALL test_idxvec_from_stripes(stripes, ref_indices)
279 END SUBROUTINE test_stripes5
280
281 SUBROUTINE test_stripes6
282 TYPE(xt_stripe), PARAMETER :: stripes(3) &
284 INTEGER(xt_int_kind), PARAMETER :: ref_indices(15) &
285 = (/ 0_xi, 3_xi, 6_xi, 9_xi, 12_xi, &
286 & 2_xi, 5_xi, 8_xi, 11_xi, 14_xi, &
287 & 14_xi, 11_xi, 8_xi, 5_xi, 2_xi /)
288 CALL test_idxvec_from_stripes(stripes, ref_indices)
289 END SUBROUTINE test_stripes6
290
291 SUBROUTINE test_stripes7
292 TYPE(xt_stripe),
PARAMETER :: stripes(4) = (/
xt_stripe(0, -1, 5), &
294 INTEGER(xt_int_kind), PARAMETER :: ref_indices(20) &
295 = (/ 0_xi, -1_xi, -2_xi, -3_xi, -4_xi, &
296 & 1_xi, 2_xi, 3_xi, 4_xi, 5_xi, &
297 & -5_xi, -6_xi, -7_xi, -8_xi, -9_xi, &
298 & 6_xi, 7_xi, 8_xi, 9_xi, 10_xi /)
299 CALL test_idxvec_from_stripes(stripes, ref_indices)
300 END SUBROUTINE test_stripes7
301
302 SUBROUTINE test_get_indices_at_positions(indices, undef_idx, pos)
303 INTEGER(xt_int_kind), INTENT(in) :: indices(:), undef_idx
304 INTEGER, INTENT(in) :: pos(:)
305 INTEGER(xt_int_kind) :: ref_sel_idx(SIZE(pos)), sel_idx(SIZE(pos))
306 INTEGER :: i, num_pos, undef_count, ref_undef_count
307 TYPE(xt_idxlist) :: idxvec
308 CHARACTER(80) :: msg
309 num_pos = SIZE(pos)
311 ref_undef_count = 0
312 DO i = 1, num_pos
314 THEN
315 ref_sel_idx(i) = undef_idx
316 ref_undef_count = ref_undef_count + 1
317 END IF
318 END DO
320 undef_idx)
321 IF (undef_count /= ref_undef_count) THEN
322 CALL test_abort("test_idxvec_f.f90: (undef_count /= ref_undef_count)", &
323 filename, __line__)
324 END IF
325 DO i = 1, num_pos
326 IF (sel_idx(i) /= ref_sel_idx(i)) THEN
327 WRITE (msg, '(2(a,i0),a)') "test_idxvec_f.f90: (sel_idx(", i, &
328 ") /= ref_sel_idx(", i, "))"
329 CALL test_abort(msg, filename, __line__)
330 END IF
331 END DO
333 END SUBROUTINE test_get_indices_at_positions
334
335 SUBROUTINE test_get_indices_at_positions1
336 INTEGER(xt_int_kind), PARAMETER :: indices(16) &
337 = (/ 0_xi, 3_xi, 6_xi, 9_xi, 12_xi, 1_xi, 4_xi, 7_xi, &
338 & 10_xi, 13_xi, 14_xi, 11_xi, 8_xi, 5_xi, 2_xi, 1_xi /)
339 INTEGER(xt_int_kind), PARAMETER :: undef_idx = -huge(undef_idx)
340 INTEGER, PARAMETER :: pos(13) &
341 = (/ 0, 2, 7, 9, 11, 100, 11, 200, 9, 300, 7, 400, 5 /)
342 CALL test_get_indices_at_positions(indices, undef_idx, pos)
343 END SUBROUTINE test_get_indices_at_positions1
344
345 SUBROUTINE test_get_indices_at_positions2
346 INTEGER(xt_int_kind), PARAMETER :: indices(16) &
347 = (/ 0_xi, 3_xi, 6_xi, 9_xi, 12_xi, 1_xi, 4_xi, 7_xi, &
348 & 10_xi, 13_xi, 14_xi, 11_xi, 8_xi, 5_xi, 2_xi, 1_xi /)
349 INTEGER(xt_int_kind), PARAMETER :: undef_idx = -huge(undef_idx)
350 INTEGER, PARAMETER :: pos(9) &
351 = (/ 0, 2, 7, 9, 11, 11, 9, 7, 5 /)
352 CALL test_get_indices_at_positions(indices, undef_idx, pos)
353 END SUBROUTINE test_get_indices_at_positions2
354
355 SUBROUTINE test_get_indices_at_positions3
356 INTEGER(xt_int_kind), PARAMETER :: indices(16) &
357 = (/ 0_xi, 3_xi, 6_xi, 9_xi, 12_xi, 1_xi, 4_xi, 7_xi, &
358 & 10_xi, 13_xi, 14_xi, 11_xi, 8_xi, 5_xi, 2_xi, 1_xi /)
359 INTEGER(xt_int_kind), PARAMETER :: undef_idx = -huge(indices(1))
360 INTEGER, PARAMETER :: pos(9) &
361 = (/ 100, 102, 107, 109, 1011, 1011, 109, 107, 105 /)
362 CALL test_get_indices_at_positions(indices, undef_idx, pos)
363 END SUBROUTINE test_get_indices_at_positions3
364
365 SUBROUTINE test_get_positions_of_indices
366 INTEGER(xt_int_kind), PARAMETER :: indices(2) = (/ 0_xi, 2_xi /), &
367 selection(3) = (/ 1_xi, 2_xi, 3_xi /)
368 INTEGER :: i, position, positions(SIZE(selection))
369 INTEGER, PARAMETER :: ref_positions(3) = (/ -1, 1, -1 /)
370 TYPE(xt_idxlist) :: idxvec
371
374 position)) &
375 CALL test_abort('xt_idxlist_get_position_of_index did not return &
376 &an error', &
377 filename, __line__)
379 position, 0)) &
380 CALL test_abort('xt_idxlist_get_position_of_index_off did not return &
381 &an error', &
382 filename, __line__)
384 position, 1)) &
385 CALL test_abort('xt_idxlist_get_position_of_index_off did not return &
386 &an error', &
387 filename, __line__)
389 .false.) /= 2) THEN
390 CALL test_abort('xt_idxlist_get_positions_of_indices did not return &
391 &correct number of matches', &
392 filename, __line__)
393 END IF
394 DO i = 1, SIZE(selection)
395 IF (positions(i) /= ref_positions(i)) &
396 CALL test_abort('xt_idxlist_get_positions_of_indices returned &
397 &incorrect position', &
398 filename, __line__)
399 END DO
401 END SUBROUTINE test_get_positions_of_indices
402
403 SUBROUTINE test_bounding_box(indices, global_size, global_start_index, &
404 ref_bounds)
405 INTEGER(xt_int_kind), INTENT(in) :: indices(:), global_size(:), &
406 global_start_index
407 TYPE(xt_bounds), INTENT(in) :: ref_bounds(:)
408
409 TYPE(xt_bounds) :: bounds(SIZE(global_size))
410 INTEGER :: i, ndim
411 TYPE(xt_idxlist) :: idxvec
412 CHARACTER(80) :: msg
413
414 ndim = SIZE(global_size)
415 IF (SIZE(ref_bounds) /= ndim) &
416 CALL test_abort('ERROR: inequal dimensions', filename, __line__)
417
419
421 global_start_index)
422
423 DO i = 1, ndim
424 IF (bounds(i)%start /= ref_bounds(i)%start) THEN
425 WRITE (0, '(2(a,i0))') 'bounds(', i, ')%start=', bounds(i)%start
426 WRITE (0, '(2(a,i0))') 'ref_bounds(', i, ')%start=', ref_bounds(i)%start
427 WRITE (msg, '(a,i0)') "ERROR: xt_idxlist_get_bounding_box inequal &
428 &starts at i=", i
429 CALL test_abort(msg, filename, __line__)
430 END IF
431 IF (bounds(i)%size /= ref_bounds(i)%size) THEN
432 WRITE (0, '(2(a,i0))') 'bounds(', i, ')%size=', bounds(i)%size
433 WRITE (0, '(2(a,i0))') 'ref_bounds(', i, ')%size=', ref_bounds(i)%size
434 WRITE (msg, '(a,i0)') "ERROR: xt_idxlist_get_bounding_box inequal &
435 &size at i=", i
436 CALL test_abort(msg, filename, __line__)
437 END IF
438 END DO
440 END SUBROUTINE test_bounding_box
441
442 SUBROUTINE test_bounding_box1
443 INTEGER(xt_int_kind), PARAMETER :: indices(2) = (/ 21_xi, 42_xi /), &
444 global_size(3) = 4_xi, global_start_index = 0_xi
445 TYPE(xt_bounds),
PARAMETER :: ref_bounds(3) =
xt_bounds(1_xi, 2_xi)
446 CALL test_bounding_box(indices, global_size, global_start_index, ref_bounds)
447 END SUBROUTINE test_bounding_box1
448
449 SUBROUTINE test_bounding_box2
450 INTEGER(xt_int_kind), PARAMETER :: indices(5) &
451 = (/ 45_xi, 35_xi, 32_xi, 48_xi, 33_xi /), &
452 global_size(3) = (/ 5_xi, 4_xi, 3_xi /), global_start_index = 1_xi
453 TYPE(xt_bounds), PARAMETER :: ref_bounds(3) &
455 CALL test_bounding_box(indices, global_size, global_start_index, ref_bounds)
456 END SUBROUTINE test_bounding_box2
457
458 SUBROUTINE test_bounding_box3
459 INTEGER(xt_int_kind), PARAMETER :: indices(1) = (/ -1_xi /), &
460 global_size(3) = 4_xi, global_start_index = 0_xi
461 TYPE(xt_bounds),
PARAMETER :: ref_bounds(3) =
xt_bounds(0, 0)
462 CALL test_bounding_box(indices(1:0), global_size, global_start_index, &
463 ref_bounds)
464 END SUBROUTINE test_bounding_box3
465
466 SUBROUTINE setup_idxvec(idxlist, index_vector)
467 TYPE(xt_idxlist), INTENT(out) :: idxlist
468 INTEGER(xt_int_kind), INTENT(in) :: index_vector(:)
469
471 CALL check_idxlist(idxlist, index_vector)
472 END SUBROUTINE setup_idxvec
473
474 SUBROUTINE compare_stripes(idxlist, ref_stripes)
475 TYPE(xt_idxlist), INTENT(in) :: idxlist
476 TYPE(xt_stripe), INTENT(in) :: ref_stripes(:)
477
478 TYPE(xt_stripe), ALLOCATABLE :: stripes(:)
479
481
482 CALL check_stripes(stripes, ref_stripes)
483
484 END SUBROUTINE compare_stripes
485
486END PROGRAM test_idxvec
487
488
489
490
491
492
493
494
495
void xt_initialize(MPI_Comm default_comm)
int xt_idxlist_get_positions_of_indices(Xt_idxlist idxlist, const Xt_int *indices, int num_indices, int *positions, int single_match_only)
int xt_idxlist_get_index_at_position(Xt_idxlist idxlist, int position, Xt_int *index)
int xt_idxlist_get_position_of_index_off(Xt_idxlist idxlist, Xt_int index, int *position, int offset)
int xt_idxlist_get_indices_at_positions(Xt_idxlist idxlist, const int *positions, int num_pos, Xt_int *indices, Xt_int undef_idx)
void xt_idxlist_get_index_stripes(Xt_idxlist idxlist, struct Xt_stripe **stripes, int *num_stripes)
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])
Xt_idxlist xt_idxlist_get_intersection(Xt_idxlist idxlist_src, Xt_idxlist idxlist_dst)
Xt_idxlist xt_idxlist_copy(Xt_idxlist idxlist)
int xt_idxlist_get_position_of_index(Xt_idxlist idxlist, Xt_int index, int *position)
void xt_idxlist_delete(Xt_idxlist idxlist)
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)