Yet Another eXchange Tool 0.11.3
Loading...
Searching...
No Matches
xt_idxlist_f.f90
Go to the documentation of this file.
1
13
14!
15! Keywords:
16! Maintainer: Jörg Behrens <behrens@dkrz.de>
17! Moritz Hanke <hanke@dkrz.de>
18! Thomas Jahns <jahns@dkrz.de>
19! URL: https://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
20!
21! Redistribution and use in source and binary forms, with or without
22! modification, are permitted provided that the following conditions are
23! met:
24!
25! Redistributions of source code must retain the above copyright notice,
26! this list of conditions and the following disclaimer.
27!
28! Redistributions in binary form must reproduce the above copyright
29! notice, this list of conditions and the following disclaimer in the
30! documentation and/or other materials provided with the distribution.
31!
32! Neither the name of the DKRZ GmbH nor the names of its contributors
33! may be used to endorse or promote products derived from this software
34! without specific prior written permission.
35!
36! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
37! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
38! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
39! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
40! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
41! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
42! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
43! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
44! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
45! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
46! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
47!
48#include "fc_feature_defs.inc"
49MODULE xt_idxlist_abstract
50 USE xt_core, ONLY: xt_int_kind, xt_mpi_fint_kind, xt_stripe, &
51 xt_bounds, xt_abort, i2, i4, i8, &
52 xt_pos_ext, OPERATOR(==)
54 USE iso_c_binding, ONLY: c_ptr, c_int, c_f_pointer, c_null_ptr, &
55 c_associated, c_loc
56 IMPLICIT NONE
57 PRIVATE
58
59 ! note: this type must not be extended to contain any other
60 ! components, its memory pattern has to match void * exactly, which
61 ! it does because of C constraints
62 TYPE, BIND(C), PUBLIC :: xt_idxlist
63#ifndef __G95__
64 PRIVATE
65#endif
66 TYPE(c_ptr) :: cptr = c_null_ptr
67 END TYPE xt_idxlist
68
69 INTERFACE
70
71 ! this function must not be implemented in Fortran because
72 ! PGI 11.x chokes on that
73 FUNCTION xt_idxlist_f2c(idxlist) bind(c, name='xt_idxlist_f2c') RESULT(p)
74 IMPORT :: c_ptr, xt_idxlist
75 IMPLICIT NONE
76 TYPE(xt_idxlist), INTENT(in) :: idxlist
77 TYPE(c_ptr) :: p
78 END FUNCTION xt_idxlist_f2c
79
80 FUNCTION xt_idxlist_get_pack_size(idxlist, comm) &
81 bind(c, name='xt_idxlist_get_pack_size_f2c') result(pack_size)
82 IMPORT :: xt_idxlist, xt_mpi_fint_kind
83 IMPLICIT NONE
84 TYPE(xt_idxlist), INTENT(in) :: idxlist
85 INTEGER(xt_mpi_fint_kind), VALUE, INTENT(in) :: comm
86 INTEGER(xt_mpi_fint_kind) :: pack_size
87 END FUNCTION xt_idxlist_get_pack_size
88
89 END INTERFACE
90 ! xt_idxlist_pack_f(type(xt_idxlist), intent(out) :: idxlist,
91 ! type<*>, intent(inout) :: buffer, integer,
92 ! intent(in) :: buffer_size,
93 ! integer, intent(inout) :: position, integer,
94 ! intent(in) :: comm)
95 EXTERNAL :: xt_idxlist_pack_f
96
97 ! xt_idxlist_unpack_f(type(xt_idxlist), intent(out) :: idxlist,
98 ! type<*>, intent(in) :: buffer,
99 ! integer, intent(in) :: buffer_size,
100 ! integer, intent(inout) :: position, integer,
101 ! intent(in) :: comm)
102 EXTERNAL :: xt_idxlist_unpack_f
103
105 xt_idxlist_f2c, xt_idxlist_c2f, xt_is_null, &
106 xt_idxlist_pack_f, xt_idxlist_unpack_f, xt_idxlist_copy, &
120 INTERFACE
121
122 FUNCTION xt_idxlist_get_num_indices_c(idxlist) RESULT(num_indices) &
123 bind(c, name='xt_idxlist_get_num_indices')
124 IMPORT :: c_int, c_ptr
125 IMPLICIT NONE
126 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
127 INTEGER(c_int) :: num_indices
128 END FUNCTION xt_idxlist_get_num_indices_c
129
130 SUBROUTINE xt_idxlist_get_indices_c(idxlist, indices) &
131 bind(c, name='xt_idxlist_get_indices')
132 IMPORT :: c_ptr, xt_int_kind
133 IMPLICIT NONE
134 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
135 INTEGER(xt_int_kind), INTENT(out) :: indices(*)
136 END SUBROUTINE xt_idxlist_get_indices_c
137
138 SUBROUTINE xt_idxlist_delete_c(idxlist) bind(C, name='xt_idxlist_delete')
139 IMPORT :: c_ptr
140 IMPLICIT NONE
141 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
142 END SUBROUTINE xt_idxlist_delete_c
143
144 FUNCTION xt_idxlist_get_indices_at_positions_c(idxlist, positions, &
145 num_pos, indices, undef_idx) &
146 bind(c, name='xt_idxlist_get_indices_at_positions') result(num_subst)
147 IMPORT :: c_ptr, c_int, xt_int_kind
148 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
149 INTEGER(c_int), INTENT(in) :: positions(*)
150 INTEGER(c_int), VALUE, INTENT(in) :: num_pos
151 INTEGER(xt_int_kind), VALUE, INTENT(in) :: undef_idx
152 INTEGER(xt_int_kind), INTENT(out) :: indices(*)
153 INTEGER(c_int) :: num_subst
154 END FUNCTION xt_idxlist_get_indices_at_positions_c
155
156 END INTERFACE
157
158 INTERFACE xt_idxlist_delete
159 MODULE PROCEDURE xt_idxlist_delete_1
160 MODULE PROCEDURE xt_idxlist_delete_a1d
161 MODULE PROCEDURE xt_idxlist_delete_a2d
162 END INTERFACE xt_idxlist_delete
163
164 INTERFACE xt_idxlist_get_indices
165 MODULE PROCEDURE xt_idxlist_get_indices_1d
166 MODULE PROCEDURE xt_idxlist_get_indices_2d
167 MODULE PROCEDURE xt_idxlist_get_indices_3d
168 MODULE PROCEDURE xt_idxlist_get_indices_4d
169 MODULE PROCEDURE xt_idxlist_get_indices_5d
170 MODULE PROCEDURE xt_idxlist_get_indices_6d
171 MODULE PROCEDURE xt_idxlist_get_indices_7d
172 END INTERFACE xt_idxlist_get_indices
173
174 INTERFACE xt_is_null
175 MODULE PROCEDURE xt_idxlist_is_null
176 END INTERFACE xt_is_null
177
179 MODULE PROCEDURE xt_idxlist_get_indices_at_positions_a1d
180 MODULE PROCEDURE xt_idxlist_get_indices_at_positions_a1d_i2
181 MODULE PROCEDURE xt_idxlist_get_indices_at_positions_a1d_i4
182 MODULE PROCEDURE xt_idxlist_get_indices_at_positions_a1d_i8
184
185 INTERFACE
186 FUNCTION xt_idxlist_get_pos_exts_of_index_stripes_c(idxlist, &
187 num_stripes, stripes, num_ext, pos_ext, single_match_only) &
188 bind(c, name='xt_idxlist_get_pos_exts_of_index_stripes') &
189 result(num_unmatched)
190 IMPORT :: c_ptr, c_int
191 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
192 INTEGER(c_int), VALUE, INTENT(in) :: num_stripes
193 TYPE(c_ptr), VALUE, INTENT(in) :: stripes
194 INTEGER(c_int), INTENT(out) :: num_ext
195 TYPE(c_ptr), INTENT(out) :: pos_ext
196 INTEGER(c_int), VALUE, INTENT(in) :: single_match_only
197 INTEGER(c_int) :: num_unmatched
198 END FUNCTION xt_idxlist_get_pos_exts_of_index_stripes_c
199
200 SUBROUTINE free_c(p) bind(c, name='free')
201 IMPORT :: c_ptr
202 TYPE(c_ptr), VALUE, INTENT(in) :: p
203 END SUBROUTINE free_c
204 END INTERFACE
205
207 MODULE PROCEDURE gpe_is_i4_a_i4_p1d_l
208 MODULE PROCEDURE gpe_is_a_p1d_l
210
211 INTERFACE xt_idxlist_sorted_copy
212 MODULE PROCEDURE xt_idxlist_sorted_copy
213 MODULE PROCEDURE xt_idxlist_sorted_copy_custom
214 END INTERFACE xt_idxlist_sorted_copy
215
216 CHARACTER(len=*), PARAMETER :: filename = 'xt_idxlist_f.f90'
217CONTAINS
218
219 FUNCTION xt_idxlist_is_null(idxlist) RESULT(p)
220 TYPE(xt_idxlist), INTENT(in) :: idxlist
221 LOGICAL :: p
222 p = .NOT. c_associated(idxlist%cptr)
223 END FUNCTION xt_idxlist_is_null
224
225 SUBROUTINE xt_idxlist_delete_1(idxlist)
226 TYPE(xt_idxlist), INTENT(inout) :: idxlist
227 CALL xt_idxlist_delete_c(idxlist%cptr)
228 idxlist%cptr = c_null_ptr
229 END SUBROUTINE xt_idxlist_delete_1
230
231 SUBROUTINE xt_idxlist_delete_a1d(idxlists)
232 TYPE(xt_idxlist), INTENT(inout) :: idxlists(:)
233 INTEGER :: i, n
234 n = SIZE(idxlists)
235 DO i = 1, n
236 CALL xt_idxlist_delete_c(idxlists(i)%cptr)
237 idxlists(i)%cptr = c_null_ptr
238 END DO
239 END SUBROUTINE xt_idxlist_delete_a1d
240
241 SUBROUTINE xt_idxlist_delete_a2d(idxlists)
242 TYPE(xt_idxlist), INTENT(inout) :: idxlists(:, :)
243 INTEGER :: i, j, m, n
244 m = SIZE(idxlists, 1)
245 n = SIZE(idxlists, 2)
246 DO j = 1, n
247 DO i = 1, m
248 CALL xt_idxlist_delete_c(idxlists(i, j)%cptr)
249 idxlists(i, j)%cptr = c_null_ptr
250 END DO
251 END DO
252 END SUBROUTINE xt_idxlist_delete_a2d
253
254 FUNCTION xt_idxlist_get_index_at_position(idxlist, position, idx) RESULT(res)
255 IMPLICIT NONE
256 TYPE(xt_idxlist), INTENT(in) :: idxlist
257 INTEGER, VALUE, INTENT(in) :: position
258 INTEGER(xt_int_kind), INTENT(out) :: idx
259 LOGICAL :: res
260 INTEGER(c_int) :: position_c
261
262 INTERFACE
263 FUNCTION xt_idxlist_get_index_at_position_c(idxlist, position, idx) &
264 bind(c, name='xt_idxlist_get_index_at_position') result(res)
265 IMPORT :: c_ptr, c_int, xt_int_kind
266 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
267 INTEGER(c_int), VALUE, INTENT(in) :: position
268 INTEGER(xt_int_kind), INTENT(out) :: idx
269 INTEGER(c_int) :: res
270 END FUNCTION xt_idxlist_get_index_at_position_c
271 END INTERFACE
272
273 position_c = int(position, c_int)
274 res = xt_idxlist_get_index_at_position_c(idxlist%cptr, &
275 position_c, idx) /= 0
277
278 FUNCTION xt_idxlist_get_indices_at_positions_a1d(idxlist, positions, &
279 indices, undef_idx) RESULT(num_subst)
280 IMPLICIT NONE
281 TYPE(xt_idxlist), INTENT(in) :: idxlist
282 INTEGER, INTENT(in) :: positions(:)
283 INTEGER(xt_int_kind), INTENT(out) :: indices(:)
284 INTEGER(xt_int_kind), INTENT(in) :: undef_idx
285 INTEGER :: num_subst, n
286 INTEGER(c_int) :: num_positions_c
287
288 n = SIZE(positions)
289 IF (n > huge(1_c_int)) n = huge(1_c_int)
290
291 num_positions_c = int(n, c_int)
292 num_subst = xt_idxlist_get_indices_at_positions_c(idxlist%cptr, &
293 int(positions, c_int), num_positions_c, &
294 indices, undef_idx)
295 END FUNCTION xt_idxlist_get_indices_at_positions_a1d
296
297 FUNCTION xt_idxlist_get_indices_at_positions_a1d_i2(idxlist, positions, &
298 num_pos, indices, undef_idx) RESULT(num_subst)
299 IMPLICIT NONE
300 TYPE(xt_idxlist), INTENT(in) :: idxlist
301 INTEGER, INTENT(in) :: positions(*)
302 INTEGER(xt_int_kind), INTENT(out) :: indices(*)
303 INTEGER(xt_int_kind), INTENT(in) :: undef_idx
304 INTEGER(i2), INTENT(in) :: num_pos
305 INTEGER :: num_subst
306 INTEGER(c_int) :: num_pos_c
307
308 num_pos_c = int(num_pos, c_int)
309 num_subst = xt_idxlist_get_indices_at_positions_c(idxlist%cptr, &
310 int(positions(1:num_pos), c_int), num_pos_c, &
311 indices, undef_idx)
312 END FUNCTION xt_idxlist_get_indices_at_positions_a1d_i2
313
314 FUNCTION xt_idxlist_get_indices_at_positions_a1d_i4(idxlist, positions, &
315 num_pos, indices, undef_idx) RESULT(num_subst)
316 IMPLICIT NONE
317 TYPE(xt_idxlist), INTENT(in) :: idxlist
318 INTEGER, INTENT(in) :: positions(*)
319 INTEGER(xt_int_kind), INTENT(out) :: indices(*)
320 INTEGER(xt_int_kind), INTENT(in) :: undef_idx
321 INTEGER(i4), INTENT(in) :: num_pos
322 INTEGER :: num_subst
323 INTEGER(c_int) :: num_pos_c
324
325 IF (num_pos > huge(1_c_int) .OR. num_pos < 0) &
326 CALL xt_abort("invalid number of positions", filename, __line__)
327
328 num_pos_c = int(num_pos, c_int)
329 num_subst = xt_idxlist_get_indices_at_positions_c(idxlist%cptr, &
330 int(positions(1:num_pos), c_int), num_pos_c, indices, undef_idx)
331 END FUNCTION xt_idxlist_get_indices_at_positions_a1d_i4
332
333 FUNCTION xt_idxlist_get_indices_at_positions_a1d_i8(idxlist, positions, &
334 num_pos, indices, undef_idx) RESULT(num_subst)
335 IMPLICIT NONE
336 TYPE(xt_idxlist), INTENT(in) :: idxlist
337 INTEGER, INTENT(in) :: positions(*)
338 INTEGER(xt_int_kind), INTENT(out) :: indices(*)
339 INTEGER(xt_int_kind), INTENT(in) :: undef_idx
340 INTEGER(i8), INTENT(in) :: num_pos
341 INTEGER :: num_subst
342 INTEGER(c_int) :: num_pos_c
343
344 IF (num_pos > huge(1_c_int) .OR. num_pos < 0) &
345 CALL xt_abort("invalid number of positions", filename, __line__)
346
347 num_pos_c = int(num_pos, c_int)
348 num_subst = xt_idxlist_get_indices_at_positions_c(idxlist%cptr, &
349 int(positions(1:num_pos), c_int), num_pos_c, indices, undef_idx)
350 END FUNCTION xt_idxlist_get_indices_at_positions_a1d_i8
351
352 FUNCTION xt_idxlist_get_position_of_index(idxlist, idx, position) &
353 result(notfound)
354 IMPLICIT NONE
355 TYPE(xt_idxlist), INTENT(in) :: idxlist
356 INTEGER(xt_int_kind), VALUE, INTENT(in) :: idx
357 INTEGER, INTENT(out) :: position
358 LOGICAL :: notfound
359 INTEGER(c_int) :: position_c
360
361 INTERFACE
362 FUNCTION xt_idxlist_get_position_of_index_c(idxlist, idx, position) &
363 bind(c, name='xt_idxlist_get_position_of_index') result(res)
364 IMPORT :: xt_idxlist, xt_int_kind, c_int, c_ptr
365 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
366 INTEGER(xt_int_kind), VALUE, INTENT(in) :: idx
367 INTEGER(c_int), INTENT(out) :: position
368 INTEGER(c_int) :: res
369 END FUNCTION xt_idxlist_get_position_of_index_c
370 END INTERFACE
371
372 notfound = xt_idxlist_get_position_of_index_c(idxlist%cptr, &
373 idx, position_c) /= 0
374 position = int(position_c)
376
377 FUNCTION xt_idxlist_get_position_of_index_off(idxlist, idx, position, &
378 offset) RESULT(notfound)
379 IMPLICIT NONE
380 TYPE(xt_idxlist), INTENT(in) :: idxlist
381 INTEGER(xt_int_kind), VALUE, INTENT(in) :: idx
382 INTEGER, INTENT(out) :: position
383 INTEGER, INTENT(in) :: offset
384 LOGICAL :: notfound
385 INTEGER(c_int) :: position_c, offset_c
386
387 INTERFACE
388 FUNCTION xt_idxlist_get_position_of_index_off_c(idxlist, idx, position, &
389 offset) bind(c, name='xt_idxlist_get_position_of_index_off') &
390 result(res)
391 IMPORT :: xt_idxlist, xt_int_kind, c_int, c_ptr
392 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
393 INTEGER(xt_int_kind), VALUE, INTENT(in) :: idx
394 INTEGER(c_int), INTENT(out) :: position
395 INTEGER(c_int), VALUE, INTENT(in) :: offset
396 INTEGER(c_int) :: res
397 END FUNCTION xt_idxlist_get_position_of_index_off_c
398 END INTERFACE
399
400 offset_c = int(offset, c_int)
401 notfound = xt_idxlist_get_position_of_index_off_c(idxlist%cptr, &
402 idx, position_c, offset_c) /= 0
403 position = int(position_c)
405
406 FUNCTION xt_idxlist_get_positions_of_indices(idxlist, indices, positions, &
407 single_match_only) RESULT(num_missing)
408 IMPLICIT NONE
409 TYPE(xt_idxlist), INTENT(in) :: idxlist
410 INTEGER(xt_int_kind), INTENT(in) :: indices(:)
411 INTEGER, INTENT(out) :: positions(:)
412 LOGICAL, INTENT(in) :: single_match_only
413 INTEGER :: num_missing, n, ofs
414 INTEGER(c_int) :: single_match_only_, num_pos_c
415
416 INTERFACE
417 FUNCTION xt_idxlist_get_positions_of_indices_c(idxlist, indices, &
418 num_indices, positions, single_match_only) &
419 bind(c, name='xt_idxlist_get_positions_of_indices') &
420 result(num_missing)
421 IMPORT :: xt_idxlist, xt_int_kind, c_int, c_ptr
422 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
423 INTEGER(xt_int_kind), INTENT(in) :: indices(*)
424 INTEGER(c_int), VALUE, INTENT(in) :: num_indices
425 INTEGER(c_int), INTENT(out) :: positions(*)
426 INTEGER(c_int), VALUE, INTENT(in) :: single_match_only
427 INTEGER(c_int) :: num_missing
428 END FUNCTION xt_idxlist_get_positions_of_indices_c
429 END INTERFACE
430
431 n = SIZE(indices)
432 IF (SIZE(positions) < n) THEN
433 CALL xt_abort("positions array too small", filename, __line__)
434 END IF
435 num_missing = 0
436 ofs = 1
437 single_match_only_ = merge(1_c_int, 0_c_int, single_match_only)
438 DO WHILE (n > 0)
439 IF (n > huge(1_c_int)) THEN
440 num_missing = num_missing &
441 + int(xt_idxlist_get_positions_of_indices_c(&
442 idxlist%cptr, indices(ofs:), huge(1_c_int), &
443 positions(ofs:), single_match_only_))
444 ofs = ofs + huge(1_c_int)
445 n = n - huge(1_c_int)
446 ELSE
447 num_pos_c = int(n, c_int)
448 num_missing = num_missing &
449 + int(xt_idxlist_get_positions_of_indices_c(&
450 idxlist%cptr, indices(ofs:), &
451 num_pos_c, positions(ofs:), single_match_only_))
452 n = 0
453 END IF
454 END DO
456
457 FUNCTION xt_idxlist_get_num_index_stripes(idxlist) &
458 result(num_stripes)
459 TYPE(xt_idxlist), INTENT(in) :: idxlist
460 INTEGER :: num_stripes
461
462 INTERFACE
463 FUNCTION xt_idxlist_get_num_index_stripes_c(idxlist) &
464 bind(c, name='xt_idxlist_get_num_index_stripes') result(num_stripes)
465 IMPORT :: c_ptr, c_int
466 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
467 INTEGER(c_int) :: num_stripes
468 END FUNCTION xt_idxlist_get_num_index_stripes_c
469 END INTERFACE
470
471 INTEGER(c_int) :: num_stripes_c
472
473 num_stripes_c = xt_idxlist_get_num_index_stripes_c(idxlist%cptr)
474 IF (num_stripes_c > huge(num_stripes)) &
475 CALL xt_abort("number of stripes too large", filename, __line__)
476 num_stripes = int(num_stripes_c)
478
479 FUNCTION xt_idxlist_get_min_index(idxlist) &
480 result(min_index)
481 TYPE(xt_idxlist), INTENT(in) :: idxlist
482 INTEGER(xt_int_kind) :: min_index
483
484 INTERFACE
485 FUNCTION xt_idxlist_get_min_index_c(idxlist) &
486 bind(c, name='xt_idxlist_get_min_index') result(min_index)
487 IMPORT :: c_ptr, xt_int_kind
488 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
489 INTEGER(xt_int_kind) :: min_index
490 END FUNCTION xt_idxlist_get_min_index_c
491 END INTERFACE
492
493 min_index = xt_idxlist_get_min_index_c(idxlist%cptr)
494 END FUNCTION xt_idxlist_get_min_index
495
496 FUNCTION xt_idxlist_get_max_index(idxlist) &
497 result(max_index)
498 TYPE(xt_idxlist), INTENT(in) :: idxlist
499 INTEGER(xt_int_kind) :: max_index
500
501 INTERFACE
502 FUNCTION xt_idxlist_get_max_index_c(idxlist) &
503 bind(c, name='xt_idxlist_get_max_index') result(max_index)
504 IMPORT :: c_ptr, xt_int_kind
505 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
506 INTEGER(xt_int_kind) :: max_index
507 END FUNCTION xt_idxlist_get_max_index_c
508 END INTERFACE
509
510 max_index = xt_idxlist_get_max_index_c(idxlist%cptr)
511 END FUNCTION xt_idxlist_get_max_index
512
513 SUBROUTINE xt_idxlist_get_index_stripes(idxlist, stripes)
514 TYPE(xt_idxlist), INTENT(in) :: idxlist
515 TYPE(xt_stripe), ALLOCATABLE, INTENT(out) :: stripes(:)
516
517 INTERFACE
518 SUBROUTINE xt_idxlist_get_index_stripes_c(idxlist, stripes,&
519 num_stripes) bind(c, name='xt_idxlist_get_index_stripes')
520 IMPORT :: c_ptr, c_int
521 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
522 TYPE(c_ptr), INTENT(out) :: stripes
523 INTEGER(c_int), INTENT(out) :: num_stripes
524 END SUBROUTINE xt_idxlist_get_index_stripes_c
525 END INTERFACE
526 TYPE(c_ptr) :: stripes_c_ptr
527 INTEGER(c_int) :: num_stripes
528 TYPE(xt_stripe), POINTER :: stripes_f_ptr(:)
529 INTEGER :: stripes_shape(1)
530 CALL xt_idxlist_get_index_stripes_c(idxlist%cptr, &
531 stripes_c_ptr, num_stripes)
532 IF (num_stripes > huge(stripes_shape)) &
533 CALL xt_abort("number of stripes too large", filename, __line__)
534 stripes_shape(1) = int(num_stripes)
535 IF (num_stripes > 0) THEN
536 ALLOCATE(stripes(int(num_stripes)))
537 CALL c_f_pointer(stripes_c_ptr, stripes_f_ptr, stripes_shape)
538 stripes = stripes_f_ptr
539 END IF
540 CALL free_c(stripes_c_ptr)
541 END SUBROUTINE xt_idxlist_get_index_stripes
542
543 FUNCTION xt_idxlist_get_bounding_box(idxlist, global_size, &
544 global_start_index) RESULT(bounds)
545 TYPE(xt_idxlist), INTENT(in) :: idxlist
546 INTEGER(xt_int_kind), INTENT(in) :: global_size(:)
547 INTEGER(xt_int_kind), INTENT(in) :: global_start_index
548 TYPE(xt_bounds) :: bounds(SIZE(global_size))
549 INTEGER(c_int) :: ndim
550
551 INTERFACE
552 SUBROUTINE xt_idxlist_get_bounding_box_c(idxlist, ndim, global_size, &
553 global_start_index, bounds) &
554 bind(c, name='xt_idxlist_get_bounding_box')
555 IMPORT :: c_int, c_ptr, xt_int_kind, xt_bounds
556 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
557 INTEGER(c_int), VALUE :: ndim
558 INTEGER(xt_int_kind), INTENT(in) :: global_size(ndim)
559 INTEGER(xt_int_kind), VALUE, INTENT(in) :: global_start_index
560 TYPE(xt_bounds), INTENT(out) :: bounds(ndim)
561 END SUBROUTINE xt_idxlist_get_bounding_box_c
562 END INTERFACE
563
564 ndim = int(SIZE(global_size), c_int)
565 CALL xt_idxlist_get_bounding_box_c(idxlist%cptr, &
566 ndim, global_size, global_start_index, bounds)
567 END FUNCTION xt_idxlist_get_bounding_box
568
569 FUNCTION xt_idxlist_get_intersection(idxlist_src, idxlist_dst) &
570 result(intersection)
571 TYPE(xt_idxlist), INTENT(in) :: idxlist_src, idxlist_dst
572 TYPE(xt_idxlist) :: intersection
573
574 INTERFACE
575 FUNCTION xt_idxlist_get_intersection_c(idxlist_src, idxlist_dst) &
576 bind(c, name='xt_idxlist_get_intersection') result(intersection)
577 IMPORT :: c_ptr
578 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist_src, idxlist_dst
579 TYPE(c_ptr) :: intersection
580 END FUNCTION xt_idxlist_get_intersection_c
581 END INTERFACE
582
583 intersection = xt_idxlist_c2f(xt_idxlist_get_intersection_c(&
584 idxlist_src%cptr, idxlist_dst%cptr))
585 END FUNCTION xt_idxlist_get_intersection
586
587 FUNCTION xt_idxlist_copy(idxlist) RESULT(copy)
588 TYPE(xt_idxlist), INTENT(in) :: idxlist
589 TYPE(xt_idxlist) :: copy
590
591 INTERFACE
592 FUNCTION xt_idxlist_copy_c(idxlist) bind(c, name='xt_idxlist_copy') &
593 result(copy)
594 IMPORT :: c_ptr
595 TYPE(c_ptr), VALUE, INTENT(IN) :: idxlist
596 TYPE(c_ptr) :: copy
597 END FUNCTION xt_idxlist_copy_c
598 END INTERFACE
599
600 copy = xt_idxlist_c2f(xt_idxlist_copy_c(idxlist%cptr))
601
602 END FUNCTION xt_idxlist_copy
603
604 FUNCTION xt_idxlist_get_sorting(idxlist) RESULT(sorting)
605 TYPE(xt_idxlist), INTENT(in) :: idxlist
606 INTEGER :: sorting
607
608 INTERFACE
609 FUNCTION xt_idxlist_get_sorting_c(idxlist) &
610 bind(c, name='xt_idxlist_get_sorting') result(sorting)
611 IMPORT :: c_ptr, c_int
612 TYPE(c_ptr), VALUE, INTENT(IN) :: idxlist
613 INTEGER(c_int) :: sorting
614 END FUNCTION xt_idxlist_get_sorting_c
615 END INTERFACE
616
617 sorting = int(xt_idxlist_get_sorting_c(idxlist%cptr))
618
619 END FUNCTION xt_idxlist_get_sorting
620
621 FUNCTION xt_idxlist_sorted_copy(idxlist) RESULT(copy)
622 TYPE(xt_idxlist), INTENT(in) :: idxlist
623 TYPE(xt_idxlist) :: copy
624
625 INTERFACE
626 FUNCTION xt_idxlist_sorted_copy_c(idxlist) &
627 bind(c, name='xt_idxlist_sorted_copy') &
628 result(copy)
629 IMPORT :: c_ptr
630 TYPE(c_ptr), VALUE, INTENT(IN) :: idxlist
631 TYPE(c_ptr) :: copy
632 END FUNCTION xt_idxlist_sorted_copy_c
633 END INTERFACE
634
635 copy = xt_idxlist_c2f(xt_idxlist_sorted_copy_c(idxlist%cptr))
636
637 END FUNCTION xt_idxlist_sorted_copy
638
639 FUNCTION xt_idxlist_sorted_copy_custom(idxlist, config) RESULT(copy)
640 TYPE(xt_idxlist), INTENT(in) :: idxlist
641 TYPE(xt_config), INTENT(in) :: config
642 TYPE(xt_idxlist) :: copy
643
644 INTERFACE
645 FUNCTION xt_idxlist_sorted_copy_custom_c(idxlist, config) &
646 bind(c, name='xt_idxlist_sorted_copy_custom') &
647 result(copy)
648 IMPORT :: c_ptr
649 TYPE(c_ptr), VALUE, INTENT(IN) :: idxlist, config
650 TYPE(c_ptr) :: copy
651 END FUNCTION xt_idxlist_sorted_copy_custom_c
652 END INTERFACE
653
654 copy = xt_idxlist_c2f(xt_idxlist_sorted_copy_custom_c(idxlist%cptr, &
655 xt_config_f2c(config)))
656
658
659 FUNCTION xt_idxlist_c2f(idxlist) RESULT(p)
660 TYPE(c_ptr), INTENT(in) :: idxlist
661 TYPE(xt_idxlist) :: p
662 p%cptr = idxlist
663 END FUNCTION xt_idxlist_c2f
664
665 FUNCTION xt_idxlist_get_num_indices(idxlist) RESULT(num_indices)
666 TYPE(xt_idxlist), INTENT(in) :: idxlist
667 INTEGER :: num_indices
668 INTEGER(c_int) :: n
669 n = xt_idxlist_get_num_indices_c(idxlist%cptr)
670 IF (n > huge(num_indices) .OR. n < -huge(num_indices)) &
671 CALL xt_abort("num_indices out of bounds", filename, __line__)
672 num_indices = int(n)
673 END FUNCTION xt_idxlist_get_num_indices
674
675 SUBROUTINE xt_idxlist_get_indices_1d(idxlist, indices)
676 TYPE(xt_idxlist), INTENT(in) :: idxlist
677 INTEGER(xt_int_kind), INTENT(out) :: indices(:)
678 INTEGER(c_int) :: num_indices
679 num_indices = xt_idxlist_get_num_indices_c(idxlist%cptr)
680 IF (num_indices > SIZE(indices)) THEN
681 CALL xt_abort("indices array too small", filename, __line__)
682 END IF
683 CALL xt_idxlist_get_indices_c(idxlist%cptr, indices)
684 END SUBROUTINE xt_idxlist_get_indices_1d
685
686 SUBROUTINE xt_idxlist_get_indices_2d(idxlist, indices)
687 TYPE(xt_idxlist), INTENT(in) :: idxlist
688 INTEGER(xt_int_kind), INTENT(out) :: indices(:,:)
689 INTEGER(c_int) :: num_indices
690 num_indices = xt_idxlist_get_num_indices_c(idxlist%cptr)
691 IF (num_indices > SIZE(indices)) THEN
692 CALL xt_abort("indices array too small", filename, __line__)
693 END IF
694 CALL xt_idxlist_get_indices_c(idxlist%cptr, indices)
695 END SUBROUTINE xt_idxlist_get_indices_2d
696
697 SUBROUTINE xt_idxlist_get_indices_3d(idxlist, indices)
698 TYPE(xt_idxlist), INTENT(in) :: idxlist
699 INTEGER(xt_int_kind), INTENT(out) :: indices(:,:,:)
700 INTEGER(c_int) :: num_indices
701 num_indices = xt_idxlist_get_num_indices_c(idxlist%cptr)
702 IF (num_indices > SIZE(indices)) THEN
703 CALL xt_abort("indices array too small", filename, __line__)
704 END IF
705 CALL xt_idxlist_get_indices_c(idxlist%cptr, indices)
706 END SUBROUTINE xt_idxlist_get_indices_3d
707
708 SUBROUTINE xt_idxlist_get_indices_4d(idxlist, indices)
709 TYPE(xt_idxlist), INTENT(in) :: idxlist
710 INTEGER(xt_int_kind), INTENT(out) :: indices(:,:,:,:)
711 INTEGER(c_int) :: num_indices
712 num_indices = xt_idxlist_get_num_indices_c(idxlist%cptr)
713 IF (num_indices > SIZE(indices)) THEN
714 CALL xt_abort("indices array too small", filename, __line__)
715 END IF
716 CALL xt_idxlist_get_indices_c(idxlist%cptr, indices)
717 END SUBROUTINE xt_idxlist_get_indices_4d
718
719 SUBROUTINE xt_idxlist_get_indices_5d(idxlist, indices)
720 TYPE(xt_idxlist), INTENT(in) :: idxlist
721 INTEGER(xt_int_kind), INTENT(out) :: indices(:,:,:,:,:)
722 INTEGER(c_int) :: num_indices
723 num_indices = xt_idxlist_get_num_indices_c(idxlist%cptr)
724 IF (num_indices > SIZE(indices)) THEN
725 CALL xt_abort("indices array too small", filename, __line__)
726 END IF
727 CALL xt_idxlist_get_indices_c(idxlist%cptr, indices)
728 END SUBROUTINE xt_idxlist_get_indices_5d
729
730 SUBROUTINE xt_idxlist_get_indices_6d(idxlist, indices)
731 TYPE(xt_idxlist), INTENT(in) :: idxlist
732 INTEGER(xt_int_kind), INTENT(out) :: indices(:,:,:,:,:,:)
733 INTEGER(c_int) :: num_indices
734 num_indices = xt_idxlist_get_num_indices_c(idxlist%cptr)
735 IF (num_indices > SIZE(indices)) THEN
736 CALL xt_abort("indices array too small", filename, __line__)
737 END IF
738 CALL xt_idxlist_get_indices_c(idxlist%cptr, indices)
739 END SUBROUTINE xt_idxlist_get_indices_6d
740
741 SUBROUTINE xt_idxlist_get_indices_7d(idxlist, indices)
742 TYPE(xt_idxlist), INTENT(in) :: idxlist
743 INTEGER(xt_int_kind), INTENT(out) :: indices(:,:,:,:,:,:,:)
744 INTEGER(c_int) :: num_indices
745 num_indices = xt_idxlist_get_num_indices_c(idxlist%cptr)
746 IF (num_indices > SIZE(indices)) THEN
747 CALL xt_abort("indices array too small", filename, __line__)
748 END IF
749 CALL xt_idxlist_get_indices_c(idxlist%cptr, indices)
750 END SUBROUTINE xt_idxlist_get_indices_7d
751
752 FUNCTION xt_idxlist_get_indices_const(idxlist) RESULT(indices)
753 TYPE(xt_idxlist), INTENT(in) :: idxlist
754 INTEGER(xt_int_kind), POINTER :: indices(:)
755 INTEGER(c_int) :: num_indices
756 TYPE(c_ptr) :: c_indices
757 INTEGER(xt_int_kind), SAVE, TARGET :: dummy(1) = -huge(indices)
758 INTEGER :: indices_shape(1)
759 INTERFACE
760 FUNCTION xt_idxlist_get_indices_const_c(idxlist) &
761 bind(c, name='xt_idxlist_get_indices_const') result(indices)
762 IMPORT :: c_ptr
763 IMPLICIT NONE
764 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
765 TYPE(c_ptr) :: indices
766 END FUNCTION xt_idxlist_get_indices_const_c
767 END INTERFACE
768 num_indices = xt_idxlist_get_num_indices_c(idxlist%cptr)
769 IF (num_indices > 0_xt_int_kind) THEN
770 IF (num_indices > huge(indices_shape)) &
771 CALL xt_abort("too many indices for default integer kind", &
772 filename, __line__)
773 indices_shape(1) = int(num_indices)
774 c_indices = xt_idxlist_get_indices_const_c(idxlist%cptr)
775 CALL c_f_pointer(c_indices, indices, indices_shape)
776 ELSE
777 indices => dummy(1:0)
778 END IF
780
781 FUNCTION xt_idxlist_is_stripe_conversion_profitable(idxlist, config) &
782 result(profit)
783 TYPE(xt_idxlist), INTENT(in) :: idxlist
784 TYPE(xt_config), INTENT(in) :: config
785 INTEGER :: profit
786 INTERFACE
787 FUNCTION is_stripe_conversion_profitable_c(idxlist, config) &
788 result(profit) &
789 BIND(c, name="xt_idxlist_is_stripe_conversion_profitable")
790 IMPORT :: c_ptr, c_int
791 TYPE(c_ptr), VALUE, INTENT(in) :: idxlist, config
792 INTEGER(c_int) :: profit
793 END FUNCTION is_stripe_conversion_profitable_c
794 END INTERFACE
795 profit = int(is_stripe_conversion_profitable_c(idxlist%cptr, &
796 xt_config_f2c(config)))
798
799 FUNCTION gpe_is_i4_a_i4_p1d_l(idxlist, &
800 num_stripes, stripes, num_ext, pos_ext, single_match_only) &
801 result(num_unmatched)
802 TYPE(xt_idxlist), INTENT(in) :: idxlist
803 INTEGER(i4), INTENT(in) :: num_stripes
804 TYPE(xt_stripe), INTENT(in), TARGET :: stripes(num_stripes)
805 INTEGER, INTENT(out) :: num_ext
806 TYPE(xt_pos_ext), ALLOCATABLE, INTENT(out) :: pos_ext(:)
807 LOGICAL, INTENT(in) :: single_match_only
808 INTEGER :: num_unmatched
809
810 INTEGER(c_int) :: num_unmatched_c, num_ext_c, num_stripes_c
811 TYPE(c_ptr) :: pos_ext_c, stripes_c
812 TYPE(xt_pos_ext), POINTER :: pos_ext_fptr(:)
813 INTEGER :: pos_ext_shape(1)
814 TYPE(xt_pos_ext), TARGET :: dummy_stripe(1)
815
816 IF (num_stripes > huge(1_c_int) .OR. num_stripes < 0) &
817 CALL xt_abort("interface violation detected", filename, __line__)
818
819 IF (num_stripes > 0_i4) THEN
820 stripes_c = c_loc(stripes)
821 ELSE
822 stripes_c = c_loc(dummy_stripe)
823 END IF
824 num_stripes_c = int(num_stripes, c_int)
825 num_unmatched_c = xt_idxlist_get_pos_exts_of_index_stripes_c(&
826 idxlist%cptr, num_stripes_c, stripes_c, &
827 num_ext_c, pos_ext_c, merge(1_c_int, 0_c_int, single_match_only))
828
829 IF (num_ext_c > huge(1) .OR. num_ext_c < 0 &
830 .OR. num_unmatched_c > huge(1) .OR. num_unmatched_c < 0) &
831 CALL xt_abort("data representation problem", filename, __line__)
832 num_unmatched = int(num_unmatched_c)
833 num_ext = int(num_ext_c)
834 IF (num_ext > 0) THEN
835 ALLOCATE(pos_ext(num_ext))
836 pos_ext_shape(1) = num_ext
837 CALL c_f_pointer(pos_ext_c, pos_ext_fptr, pos_ext_shape)
838 pos_ext = pos_ext_fptr
839 CALL free_c(pos_ext_c)
840 END IF
841 END FUNCTION gpe_is_i4_a_i4_p1d_l
842
843 FUNCTION gpe_is_a_p1d_l(idxlist, stripes, pos_ext, single_match_only) &
844 result(num_unmatched)
845 TYPE(xt_idxlist), INTENT(in) :: idxlist
846 TYPE(xt_stripe), INTENT(in) :: stripes(:)
847 TYPE(xt_pos_ext), ALLOCATABLE, INTENT(out) :: pos_ext(:)
848 LOGICAL, INTENT(in) :: single_match_only
849 INTEGER :: num_unmatched
850
851 INTEGER :: num_ext
852 INTEGER(i4) :: num_stripes
853
854 num_stripes = SIZE(stripes)
855 IF (num_stripes > 0) THEN
856 num_unmatched = gpe_is_i4_a_i4_p1d_l(idxlist, num_stripes, stripes, &
857 num_ext, pos_ext, single_match_only)
858 ELSE
859 num_unmatched = 0
860 END IF
861 END FUNCTION gpe_is_a_p1d_l
862
863END MODULE xt_idxlist_abstract
864!
865! Local Variables:
866! f90-continuation-indent: 5
867! coding: utf-8
868! indent-tabs-mode: nil
869! show-trailing-whitespace: t
870! require-trailing-newline: t
871! End:
872!
describes range of positions starting with start up to start + size - 1 i.e. [start,...
Definition xt_core_f.f90:94
Xt_idxlist xt_idxlist_sorted_copy(Xt_idxlist idxlist)
Definition xt_idxlist.c:99
int xt_idxlist_get_positions_of_indices(Xt_idxlist idxlist, const Xt_int *indices, int num_indices, int *positions, int single_match_only)
Definition xt_idxlist.c:221
Xt_int xt_idxlist_get_min_index(Xt_idxlist idxlist)
Definition xt_idxlist.c:349
int xt_idxlist_is_stripe_conversion_profitable(Xt_idxlist idxlist, Xt_config config)
Definition xt_idxlist.c:495
const Xt_int * xt_idxlist_get_indices_const(Xt_idxlist idxlist)
Definition xt_idxlist.c:119
int xt_idxlist_get_index_at_position(Xt_idxlist idxlist, int position, Xt_int *index)
Definition xt_idxlist.c:176
Xt_int xt_idxlist_get_max_index(Xt_idxlist idxlist)
Definition xt_idxlist.c:354
void xt_idxlist_get_indices(Xt_idxlist idxlist, Xt_int *indices)
Definition xt_idxlist.c:113
int xt_idxlist_get_num_index_stripes(Xt_idxlist idxlist)
Definition xt_idxlist.c:129
int xt_idxlist_get_position_of_index_off(Xt_idxlist idxlist, Xt_int index, int *position, int offset)
Definition xt_idxlist.c:306
Xt_idxlist xt_idxlist_sorted_copy_custom(Xt_idxlist idxlist, Xt_config config)
Definition xt_idxlist.c:104
size_t xt_idxlist_get_pack_size(Xt_idxlist idxlist, MPI_Comm comm)
Definition xt_idxlist.c:80
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:183
void xt_idxlist_get_index_stripes(Xt_idxlist idxlist, struct Xt_stripe **stripes, int *num_stripes)
Definition xt_idxlist.c:135
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:379
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:262
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:94
int xt_idxlist_get_sorting(Xt_idxlist idxlist)
Definition xt_idxlist.c:359
int xt_idxlist_get_position_of_index(Xt_idxlist idxlist, Xt_int index, int *position)
Definition xt_idxlist.c:214
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition xt_idxlist.c:75
#define xt_idxlist_get_num_indices(idxlist)
Xt_idxlist xt_idxlist_f2c(struct xt_idxlist_f *p)
Definition yaxt_f2c.c:180
Xt_config xt_config_f2c(struct xt_config_f *p)
Definition yaxt_f2c.c:190