Yet Another eXchange Tool  0.9.0
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://doc.redmine.dkrz.de/yaxt/html/
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 !
49  USE xt_core, ONLY: xt_int_kind, xt_mpi_fint_kind, xt_stripe, &
50  xt_bounds, xt_abort, i2, i4, i8, &
51  xt_pos_ext, OPERATOR(==)
52  USE iso_c_binding, ONLY: c_ptr, c_int, c_f_pointer, c_null_ptr, &
53  c_associated, c_loc
54  IMPLICIT NONE
55  PRIVATE
56 
57  ! note: this type must not be extended to contain any other
58  ! components, its memory pattern has to match void * exactly, which
59  ! it does because of C constraints
60  TYPE, BIND(C), PUBLIC :: xt_idxlist
61 #ifndef __G95__
62  PRIVATE
63 #endif
64  TYPE(c_ptr) :: cptr = c_null_ptr
65  END TYPE xt_idxlist
66 
67  INTERFACE
68 
69  ! this function must not be implemented in Fortran because
70  ! PGI 11.x chokes on that
71  FUNCTION xt_idxlist_f2c(idxlist) bind(c, name='xt_idxlist_f2c') RESULT(p)
72  IMPORT :: c_ptr, xt_idxlist
73  IMPLICIT NONE
74  TYPE(xt_idxlist), INTENT(in) :: idxlist
75  TYPE(c_ptr) :: p
76  END FUNCTION xt_idxlist_f2c
77 
78  FUNCTION xt_idxlist_get_pack_size(idxlist, comm) &
79  bind(c, name='xt_idxlist_get_pack_size_f2c') result(pack_size)
80  IMPORT :: xt_idxlist, xt_mpi_fint_kind
81  IMPLICIT NONE
82  TYPE(xt_idxlist), INTENT(in) :: idxlist
83  INTEGER(xt_mpi_fint_kind), VALUE, INTENT(in) :: comm
84  INTEGER(xt_mpi_fint_kind) :: pack_size
85  END FUNCTION xt_idxlist_get_pack_size
86 
87  END INTERFACE
88  ! xt_idxlist_pack_f(type(xt_idxlist), intent(out) :: idxlist,
89  ! type<*>, intent(inout) :: buffer, integer,
90  ! intent(in) :: buffer_size,
91  ! integer, intent(inout) :: position, integer,
92  ! intent(in) :: comm)
93  EXTERNAL :: xt_idxlist_pack_f
94 
95  ! xt_idxlist_unpack_f(type(xt_idxlist), intent(out) :: idxlist,
96  ! type<*>, intent(in) :: buffer,
97  ! integer, intent(in) :: buffer_size,
98  ! integer, intent(inout) :: position, integer,
99  ! intent(in) :: comm)
101 
103  xt_idxlist_f2c, xt_idxlist_c2f, xt_is_null, &
112  INTERFACE
113 
114  FUNCTION xt_idxlist_get_num_indices_c(idxlist) RESULT(num_indices) &
115  bind(c, name='xt_idxlist_get_num_indices')
116  IMPORT :: c_int, c_ptr
117  IMPLICIT NONE
118  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
119  INTEGER(c_int) :: num_indices
120  END FUNCTION xt_idxlist_get_num_indices_c
121 
122  SUBROUTINE xt_idxlist_get_indices_c(idxlist, indices) &
123  bind(c, name='xt_idxlist_get_indices')
124  IMPORT :: c_ptr, xt_int_kind
125  IMPLICIT NONE
126  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
127  INTEGER(xt_int_kind), INTENT(out) :: indices(*)
128  END SUBROUTINE xt_idxlist_get_indices_c
129 
130  SUBROUTINE xt_idxlist_delete_c(idxlist) bind(C, name='xt_idxlist_delete')
131  IMPORT :: c_ptr
132  IMPLICIT NONE
133  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
134  END SUBROUTINE xt_idxlist_delete_c
135 
136  FUNCTION xt_idxlist_get_indices_at_positions_c(idxlist, positions, &
137  num_pos, indices, undef_idx) &
138  bind(c, name='xt_idxlist_get_indices_at_positions') result(num_subst)
139  IMPORT :: c_ptr, c_int, xt_int_kind
140  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
141  INTEGER(c_int), INTENT(in) :: positions(*)
142  INTEGER(c_int), VALUE, INTENT(in) :: num_pos
143  INTEGER(xt_int_kind), VALUE, INTENT(in) :: undef_idx
144  INTEGER(xt_int_kind), INTENT(out) :: indices(*)
145  INTEGER(c_int) :: num_subst
146  END FUNCTION xt_idxlist_get_indices_at_positions_c
147 
148  END INTERFACE
149 
150  INTERFACE xt_idxlist_delete
151  MODULE PROCEDURE xt_idxlist_delete_1
152  MODULE PROCEDURE xt_idxlist_delete_a1d
153  MODULE PROCEDURE xt_idxlist_delete_a2d
154  END INTERFACE xt_idxlist_delete
155 
156  INTERFACE xt_idxlist_get_indices
157  MODULE PROCEDURE xt_idxlist_get_indices_1d
158  MODULE PROCEDURE xt_idxlist_get_indices_2d
159  MODULE PROCEDURE xt_idxlist_get_indices_3d
160  MODULE PROCEDURE xt_idxlist_get_indices_4d
161  MODULE PROCEDURE xt_idxlist_get_indices_5d
162  MODULE PROCEDURE xt_idxlist_get_indices_6d
163  MODULE PROCEDURE xt_idxlist_get_indices_7d
164  END INTERFACE xt_idxlist_get_indices
165 
166  INTERFACE xt_is_null
167  MODULE PROCEDURE xt_idxlist_is_null
168  END INTERFACE xt_is_null
169 
171  MODULE PROCEDURE xt_idxlist_get_indices_at_positions_a1d
172  MODULE PROCEDURE xt_idxlist_get_indices_at_positions_a1d_i2
173  MODULE PROCEDURE xt_idxlist_get_indices_at_positions_a1d_i4
174  MODULE PROCEDURE xt_idxlist_get_indices_at_positions_a1d_i8
176 
177  INTERFACE
178  FUNCTION xt_idxlist_get_pos_exts_of_index_stripes_c(idxlist, &
179  num_stripes, stripes, num_ext, pos_ext, single_match_only) &
180  bind(c, name='xt_idxlist_get_pos_exts_of_index_stripes') &
181  result(num_unmatched)
182  IMPORT :: c_ptr, c_int
183  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
184  INTEGER(c_int), VALUE, INTENT(in) :: num_stripes
185  TYPE(c_ptr), VALUE, INTENT(in) :: stripes
186  INTEGER(c_int), INTENT(out) :: num_ext
187  TYPE(c_ptr), INTENT(out) :: pos_ext
188  INTEGER(c_int), VALUE, INTENT(in) :: single_match_only
189  INTEGER(c_int) :: num_unmatched
190  END FUNCTION xt_idxlist_get_pos_exts_of_index_stripes_c
191 
192  SUBROUTINE free_c(p) bind(c, name='free')
193  IMPORT :: c_ptr
194  TYPE(c_ptr), VALUE, INTENT(in) :: p
195  END SUBROUTINE free_c
196  END INTERFACE
197 
199  MODULE PROCEDURE gpe_is_i4_a_i4_p1d_l
200  MODULE PROCEDURE gpe_is_a_p1d_l
202 
203  CHARACTER(len=*), PARAMETER :: filename = 'xt_idxlist_f.f90'
204 CONTAINS
205 
206  FUNCTION xt_idxlist_is_null(idxlist) RESULT(p)
207  TYPE(xt_idxlist), INTENT(in) :: idxlist
208  LOGICAL :: p
209  p = .NOT. c_associated(idxlist%cptr)
210  END FUNCTION xt_idxlist_is_null
211 
212  SUBROUTINE xt_idxlist_delete_1(idxlist)
213  TYPE(xt_idxlist), INTENT(inout) :: idxlist
214  CALL xt_idxlist_delete_c(xt_idxlist_f2c(idxlist))
215  idxlist%cptr = c_null_ptr
216  END SUBROUTINE xt_idxlist_delete_1
217 
218  SUBROUTINE xt_idxlist_delete_a1d(idxlists)
219  TYPE(xt_idxlist), INTENT(inout) :: idxlists(:)
220  INTEGER :: i, n
221  n = SIZE(idxlists)
222  DO i = 1, n
223  CALL xt_idxlist_delete_c(xt_idxlist_f2c(idxlists(i)))
224  idxlists(i)%cptr = c_null_ptr
225  END DO
226  END SUBROUTINE xt_idxlist_delete_a1d
227 
228  SUBROUTINE xt_idxlist_delete_a2d(idxlists)
229  TYPE(xt_idxlist), INTENT(inout) :: idxlists(:, :)
230  INTEGER :: i, j, m, n
231  m = SIZE(idxlists, 1)
232  n = SIZE(idxlists, 2)
233  DO j = 1, n
234  DO i = 1, m
235  CALL xt_idxlist_delete_c(xt_idxlist_f2c(idxlists(i, j)))
236  idxlists(i, j)%cptr = c_null_ptr
237  END DO
238  END DO
239  END SUBROUTINE xt_idxlist_delete_a2d
240 
241  FUNCTION xt_idxlist_get_index_at_position(idxlist, position, idx) RESULT(res)
242  IMPLICIT NONE
243  TYPE(xt_idxlist), INTENT(in) :: idxlist
244  INTEGER, VALUE, INTENT(in) :: position
245  INTEGER(xt_int_kind), INTENT(out) :: idx
246  LOGICAL :: res
247  INTEGER(c_int) :: position_c
248 
249  INTERFACE
250  FUNCTION xt_idxlist_get_index_at_position_c(idxlist, position, idx) &
251  bind(c, name='xt_idxlist_get_index_at_position') result(res)
252  IMPORT :: c_ptr, c_int, xt_int_kind
253  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
254  INTEGER(c_int), VALUE, INTENT(in) :: position
255  INTEGER(xt_int_kind), INTENT(out) :: idx
256  INTEGER(c_int) :: res
257  END FUNCTION xt_idxlist_get_index_at_position_c
258  END INTERFACE
259 
260  position_c = int(position, c_int)
261  res = xt_idxlist_get_index_at_position_c(xt_idxlist_f2c(idxlist), &
262  position_c, idx) /= 0
264 
265  FUNCTION xt_idxlist_get_indices_at_positions_a1d(idxlist, positions, &
266  indices, undef_idx) RESULT(num_subst)
267  IMPLICIT NONE
268  TYPE(xt_idxlist), INTENT(in) :: idxlist
269  INTEGER, INTENT(in) :: positions(:)
270  INTEGER(xt_int_kind), INTENT(out) :: indices(:)
271  INTEGER(xt_int_kind), INTENT(in) :: undef_idx
272  INTEGER :: num_subst, n
273  INTEGER(c_int) :: num_positions_c
274 
275  n = SIZE(positions)
276  IF (n > huge(1_c_int)) n = huge(1_c_int)
277 
278  num_positions_c = int(n, c_int)
279  num_subst = xt_idxlist_get_indices_at_positions_c(xt_idxlist_f2c(idxlist), &
280  int(positions, c_int), num_positions_c, &
281  indices, undef_idx)
282  END FUNCTION xt_idxlist_get_indices_at_positions_a1d
283 
284  FUNCTION xt_idxlist_get_indices_at_positions_a1d_i2(idxlist, positions, &
285  num_pos, indices, undef_idx) RESULT(num_subst)
286  IMPLICIT NONE
287  TYPE(xt_idxlist), INTENT(in) :: idxlist
288  INTEGER, INTENT(in) :: positions(*)
289  INTEGER(xt_int_kind), INTENT(out) :: indices(*)
290  INTEGER(xt_int_kind), INTENT(in) :: undef_idx
291  INTEGER(i2), INTENT(in) :: num_pos
292  INTEGER :: num_subst
293  INTEGER(c_int) :: num_pos_c
294 
295  num_pos_c = int(num_pos, c_int)
296  num_subst = xt_idxlist_get_indices_at_positions_c(xt_idxlist_f2c(idxlist), &
297  int(positions(1:num_pos), c_int), num_pos_c, &
298  indices, undef_idx)
299  END FUNCTION xt_idxlist_get_indices_at_positions_a1d_i2
300 
301  FUNCTION xt_idxlist_get_indices_at_positions_a1d_i4(idxlist, positions, &
302  num_pos, indices, undef_idx) RESULT(num_subst)
303  IMPLICIT NONE
304  TYPE(xt_idxlist), INTENT(in) :: idxlist
305  INTEGER, INTENT(in) :: positions(*)
306  INTEGER(xt_int_kind), INTENT(out) :: indices(*)
307  INTEGER(xt_int_kind), INTENT(in) :: undef_idx
308  INTEGER(i4), INTENT(in) :: num_pos
309  INTEGER :: num_subst
310  INTEGER(c_int) :: num_pos_c
311 
312  IF (num_pos > huge(1_c_int) .OR. num_pos < 0) &
313  CALL xt_abort("invalid number of positions", filename, __line__)
314 
315  num_pos_c = int(num_pos, c_int)
316  num_subst = xt_idxlist_get_indices_at_positions_c(xt_idxlist_f2c(idxlist), &
317  int(positions(1:num_pos), c_int), num_pos_c, indices, undef_idx)
318  END FUNCTION xt_idxlist_get_indices_at_positions_a1d_i4
319 
320  FUNCTION xt_idxlist_get_indices_at_positions_a1d_i8(idxlist, positions, &
321  num_pos, indices, undef_idx) RESULT(num_subst)
322  IMPLICIT NONE
323  TYPE(xt_idxlist), INTENT(in) :: idxlist
324  INTEGER, INTENT(in) :: positions(*)
325  INTEGER(xt_int_kind), INTENT(out) :: indices(*)
326  INTEGER(xt_int_kind), INTENT(in) :: undef_idx
327  INTEGER(i8), INTENT(in) :: num_pos
328  INTEGER :: num_subst
329  INTEGER(c_int) :: num_pos_c
330 
331  IF (num_pos > huge(1_c_int) .OR. num_pos < 0) &
332  CALL xt_abort("invalid number of positions", filename, __line__)
333 
334  num_pos_c = int(num_pos, c_int)
335  num_subst = xt_idxlist_get_indices_at_positions_c(xt_idxlist_f2c(idxlist), &
336  int(positions(1:num_pos), c_int), num_pos_c, indices, undef_idx)
337  END FUNCTION xt_idxlist_get_indices_at_positions_a1d_i8
338 
339  FUNCTION xt_idxlist_get_position_of_index(idxlist, idx, position) &
340  result(notfound)
341  IMPLICIT NONE
342  TYPE(xt_idxlist), INTENT(in) :: idxlist
343  INTEGER(xt_int_kind), VALUE, INTENT(in) :: idx
344  INTEGER, INTENT(out) :: position
345  LOGICAL :: notfound
346  INTEGER(c_int) :: position_c
347 
348  INTERFACE
349  FUNCTION xt_idxlist_get_position_of_index_c(idxlist, idx, position) &
350  bind(c, name='xt_idxlist_get_position_of_index') result(res)
351  IMPORT :: xt_idxlist, xt_int_kind, c_int, c_ptr
352  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
353  INTEGER(xt_int_kind), VALUE, INTENT(in) :: idx
354  INTEGER(c_int), INTENT(out) :: position
355  INTEGER(c_int) :: res
356  END FUNCTION xt_idxlist_get_position_of_index_c
357  END INTERFACE
358 
359  notfound = xt_idxlist_get_position_of_index_c(xt_idxlist_f2c(idxlist), &
360  idx, position_c) /= 0
361  position = int(position_c)
363 
364  FUNCTION xt_idxlist_get_position_of_index_off(idxlist, idx, position, &
365  offset) RESULT(notfound)
366  IMPLICIT NONE
367  TYPE(xt_idxlist), INTENT(in) :: idxlist
368  INTEGER(xt_int_kind), VALUE, INTENT(in) :: idx
369  INTEGER, INTENT(out) :: position
370  INTEGER, INTENT(in) :: offset
371  LOGICAL :: notfound
372  INTEGER(c_int) :: position_c, offset_c
373 
374  INTERFACE
375  FUNCTION xt_idxlist_get_position_of_index_off_c(idxlist, idx, position, &
376  offset) bind(c, name='xt_idxlist_get_position_of_index_off') &
377  result(res)
378  IMPORT :: xt_idxlist, xt_int_kind, c_int, c_ptr
379  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
380  INTEGER(xt_int_kind), VALUE, INTENT(in) :: idx
381  INTEGER(c_int), INTENT(out) :: position
382  INTEGER(c_int), VALUE, INTENT(in) :: offset
383  INTEGER(c_int) :: res
384  END FUNCTION xt_idxlist_get_position_of_index_off_c
385  END INTERFACE
386 
387  offset_c = int(offset, c_int)
388  notfound = xt_idxlist_get_position_of_index_off_c(xt_idxlist_f2c(idxlist), &
389  idx, position_c, offset_c) /= 0
390  position = int(position_c)
392 
393  FUNCTION xt_idxlist_get_positions_of_indices(idxlist, indices, positions, &
394  single_match_only) RESULT(num_missing)
395  IMPLICIT NONE
396  TYPE(xt_idxlist), INTENT(in) :: idxlist
397  INTEGER(xt_int_kind), INTENT(in) :: indices(:)
398  INTEGER, INTENT(out) :: positions(:)
399  LOGICAL, INTENT(in) :: single_match_only
400  INTEGER :: num_missing, n, ofs
401  INTEGER(c_int) :: single_match_only_, num_pos_c
402 
403  INTERFACE
404  FUNCTION xt_idxlist_get_positions_of_indices_c(idxlist, indices, &
405  num_indices, positions, single_match_only) &
406  bind(c, name='xt_idxlist_get_positions_of_indices') &
407  result(num_missing)
408  IMPORT :: xt_idxlist, xt_int_kind, c_int, c_ptr
409  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
410  INTEGER(xt_int_kind), INTENT(in) :: indices(*)
411  INTEGER(c_int), VALUE, INTENT(in) :: num_indices
412  INTEGER(c_int), INTENT(out) :: positions(*)
413  INTEGER(c_int), VALUE, INTENT(in) :: single_match_only
414  INTEGER(c_int) :: num_missing
415  END FUNCTION xt_idxlist_get_positions_of_indices_c
416  END INTERFACE
417 
418  n = SIZE(indices)
419  IF (SIZE(positions) < n) THEN
420  CALL xt_abort("positions array too small", filename, __line__)
421  END IF
422  num_missing = 0
423  ofs = 1
424  single_match_only_ = merge(1_c_int, 0_c_int, single_match_only)
425  DO WHILE (n > 0)
426  IF (n > huge(1_c_int)) THEN
427  num_missing = num_missing &
428  + int(xt_idxlist_get_positions_of_indices_c(&
429  xt_idxlist_f2c(idxlist), indices(ofs:), huge(1_c_int), &
430  positions(ofs:), single_match_only_))
431  ofs = ofs + huge(1_c_int)
432  n = n - huge(1_c_int)
433  ELSE
434  num_pos_c = int(n, c_int)
435  num_missing = num_missing &
436  + int(xt_idxlist_get_positions_of_indices_c(&
437  xt_idxlist_f2c(idxlist), indices(ofs:), &
438  num_pos_c, positions(ofs:), single_match_only_))
439  n = 0
440  END IF
441  END DO
443 
444  SUBROUTINE xt_idxlist_get_index_stripes(idxlist, stripes)
445  TYPE(xt_idxlist), INTENT(in) :: idxlist
446  TYPE(xt_stripe), ALLOCATABLE, INTENT(out) :: stripes(:)
447 
448  INTERFACE
449  SUBROUTINE xt_idxlist_get_index_stripes_c(idxlist, stripes,&
450  num_stripes) bind(c, name='xt_idxlist_get_index_stripes')
451  IMPORT :: c_ptr, c_int
452  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
453  TYPE(c_ptr), INTENT(out) :: stripes
454  INTEGER(c_int), INTENT(out) :: num_stripes
455  END SUBROUTINE xt_idxlist_get_index_stripes_c
456  END INTERFACE
457  TYPE(c_ptr) :: stripes_c_ptr
458  INTEGER(c_int) :: num_stripes
459  TYPE(xt_stripe), POINTER :: stripes_f_ptr(:)
460  INTEGER :: stripes_shape(1)
461  CALL xt_idxlist_get_index_stripes_c(xt_idxlist_f2c(idxlist), &
462  stripes_c_ptr, num_stripes)
463  IF (num_stripes > huge(stripes_shape)) &
464  CALL xt_abort("number of stripes too large", filename, __line__)
465  stripes_shape(1) = int(num_stripes)
466  IF (num_stripes > 0) THEN
467  ALLOCATE(stripes(int(num_stripes)))
468  CALL c_f_pointer(stripes_c_ptr, stripes_f_ptr, stripes_shape)
469  stripes = stripes_f_ptr
470  END IF
471  CALL free_c(stripes_c_ptr)
472  END SUBROUTINE xt_idxlist_get_index_stripes
473 
474  FUNCTION xt_idxlist_get_bounding_box(idxlist, global_size, &
475  global_start_index) RESULT(bounds)
476  TYPE(xt_idxlist), INTENT(in) :: idxlist
477  INTEGER(xt_int_kind), INTENT(in) :: global_size(:)
478  INTEGER(xt_int_kind), INTENT(in) :: global_start_index
479  TYPE(xt_bounds) :: bounds(size(global_size))
480  INTEGER(c_int) :: ndim
481 
482  INTERFACE
483  SUBROUTINE xt_idxlist_get_bounding_box_c(idxlist, ndim, global_size, &
484  global_start_index, bounds) &
485  bind(c, name='xt_idxlist_get_bounding_box')
486  IMPORT :: c_int, c_ptr, xt_int_kind, xt_bounds
487  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
488  INTEGER(c_int), VALUE :: ndim
489  INTEGER(xt_int_kind), INTENT(in) :: global_size(ndim)
490  INTEGER(xt_int_kind), VALUE, INTENT(in) :: global_start_index
491  TYPE(xt_bounds), INTENT(out) :: bounds(ndim)
492  END SUBROUTINE xt_idxlist_get_bounding_box_c
493  END INTERFACE
494 
495  ndim = int(SIZE(global_size), c_int)
496  CALL xt_idxlist_get_bounding_box_c(xt_idxlist_f2c(idxlist), &
497  ndim, global_size, global_start_index, bounds)
498  END FUNCTION xt_idxlist_get_bounding_box
499 
500  FUNCTION xt_idxlist_get_intersection(idxlist_src, idxlist_dst) &
501  result(intersection)
502  TYPE(xt_idxlist), INTENT(in) :: idxlist_src, idxlist_dst
503  TYPE(xt_idxlist) :: intersection
504 
505  INTERFACE
506  FUNCTION xt_idxlist_get_intersection_c(idxlist_src, idxlist_dst) &
507  bind(c, name='xt_idxlist_get_intersection') result(intersection)
508  IMPORT :: c_ptr
509  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist_src, idxlist_dst
510  TYPE(c_ptr) :: intersection
511  END FUNCTION xt_idxlist_get_intersection_c
512  END INTERFACE
513 
514  intersection = xt_idxlist_c2f(xt_idxlist_get_intersection_c(&
515  xt_idxlist_f2c(idxlist_src), xt_idxlist_f2c(idxlist_dst)))
516  END FUNCTION xt_idxlist_get_intersection
517 
518  FUNCTION xt_idxlist_copy(idxlist) RESULT(copy)
519  TYPE(xt_idxlist), INTENT(in) :: idxlist
520  TYPE(xt_idxlist) :: copy
521 
522  INTERFACE
523  FUNCTION xt_idxlist_copy_c(idxlist) bind(c, name='xt_idxlist_copy') &
524  result(copy)
525  IMPORT :: c_ptr
526  TYPE(c_ptr), VALUE, INTENT(IN) :: idxlist
527  TYPE(c_ptr) :: copy
528  END FUNCTION xt_idxlist_copy_c
529  END INTERFACE
530 
531  copy = xt_idxlist_c2f(xt_idxlist_copy_c(xt_idxlist_f2c(idxlist)))
532 
533  END FUNCTION xt_idxlist_copy
534 
535  FUNCTION xt_idxlist_c2f(idxlist) RESULT(p)
536  TYPE(c_ptr), INTENT(in) :: idxlist
537  TYPE(xt_idxlist) :: p
538  p%cptr = idxlist
539  END FUNCTION xt_idxlist_c2f
540 
541  FUNCTION xt_idxlist_get_num_indices(idxlist) RESULT(num_indices)
542  TYPE(xt_idxlist), INTENT(in) :: idxlist
543  INTEGER :: num_indices
544  INTEGER(c_int) :: n
545  n = xt_idxlist_get_num_indices_c(xt_idxlist_f2c(idxlist))
546  IF (n > huge(num_indices) .OR. n < -huge(num_indices)) &
547  CALL xt_abort("num_indices out of bounds", filename, __line__)
548  num_indices = int(n)
549  END FUNCTION xt_idxlist_get_num_indices
550 
551  SUBROUTINE xt_idxlist_get_indices_1d(idxlist, indices)
552  TYPE(xt_idxlist), INTENT(in) :: idxlist
553  INTEGER(xt_int_kind), INTENT(out) :: indices(:)
554  INTEGER(c_int) :: num_indices
555  num_indices = xt_idxlist_get_num_indices_c(xt_idxlist_f2c(idxlist))
556  IF (num_indices > SIZE(indices)) THEN
557  CALL xt_abort("indices array too small", filename, __line__)
558  END IF
559  CALL xt_idxlist_get_indices_c(xt_idxlist_f2c(idxlist), indices)
560  END SUBROUTINE xt_idxlist_get_indices_1d
561 
562  SUBROUTINE xt_idxlist_get_indices_2d(idxlist, indices)
563  TYPE(xt_idxlist), INTENT(in) :: idxlist
564  INTEGER(xt_int_kind), INTENT(out) :: indices(:,:)
565  INTEGER(c_int) :: num_indices
566  num_indices = xt_idxlist_get_num_indices_c(xt_idxlist_f2c(idxlist))
567  IF (num_indices > SIZE(indices)) THEN
568  CALL xt_abort("indices array too small", filename, __line__)
569  END IF
570  CALL xt_idxlist_get_indices_c(xt_idxlist_f2c(idxlist), indices)
571  END SUBROUTINE xt_idxlist_get_indices_2d
572 
573  SUBROUTINE xt_idxlist_get_indices_3d(idxlist, indices)
574  TYPE(xt_idxlist), INTENT(in) :: idxlist
575  INTEGER(xt_int_kind), INTENT(out) :: indices(:,:,:)
576  INTEGER(c_int) :: num_indices
577  num_indices = xt_idxlist_get_num_indices_c(xt_idxlist_f2c(idxlist))
578  IF (num_indices > SIZE(indices)) THEN
579  CALL xt_abort("indices array too small", filename, __line__)
580  END IF
581  CALL xt_idxlist_get_indices_c(xt_idxlist_f2c(idxlist), indices)
582  END SUBROUTINE xt_idxlist_get_indices_3d
583 
584  SUBROUTINE xt_idxlist_get_indices_4d(idxlist, indices)
585  TYPE(xt_idxlist), INTENT(in) :: idxlist
586  INTEGER(xt_int_kind), INTENT(out) :: indices(:,:,:,:)
587  INTEGER(c_int) :: num_indices
588  num_indices = xt_idxlist_get_num_indices_c(xt_idxlist_f2c(idxlist))
589  IF (num_indices > SIZE(indices)) THEN
590  CALL xt_abort("indices array too small", filename, __line__)
591  END IF
592  CALL xt_idxlist_get_indices_c(xt_idxlist_f2c(idxlist), indices)
593  END SUBROUTINE xt_idxlist_get_indices_4d
594 
595  SUBROUTINE xt_idxlist_get_indices_5d(idxlist, indices)
596  TYPE(xt_idxlist), INTENT(in) :: idxlist
597  INTEGER(xt_int_kind), INTENT(out) :: indices(:,:,:,:,:)
598  INTEGER(c_int) :: num_indices
599  num_indices = xt_idxlist_get_num_indices_c(xt_idxlist_f2c(idxlist))
600  IF (num_indices > SIZE(indices)) THEN
601  CALL xt_abort("indices array too small", filename, __line__)
602  END IF
603  CALL xt_idxlist_get_indices_c(xt_idxlist_f2c(idxlist), indices)
604  END SUBROUTINE xt_idxlist_get_indices_5d
605 
606  SUBROUTINE xt_idxlist_get_indices_6d(idxlist, indices)
607  TYPE(xt_idxlist), INTENT(in) :: idxlist
608  INTEGER(xt_int_kind), INTENT(out) :: indices(:,:,:,:,:,:)
609  INTEGER(c_int) :: num_indices
610  num_indices = xt_idxlist_get_num_indices_c(xt_idxlist_f2c(idxlist))
611  IF (num_indices > SIZE(indices)) THEN
612  CALL xt_abort("indices array too small", filename, __line__)
613  END IF
614  CALL xt_idxlist_get_indices_c(xt_idxlist_f2c(idxlist), indices)
615  END SUBROUTINE xt_idxlist_get_indices_6d
616 
617  SUBROUTINE xt_idxlist_get_indices_7d(idxlist, indices)
618  TYPE(xt_idxlist), INTENT(in) :: idxlist
619  INTEGER(xt_int_kind), INTENT(out) :: indices(:,:,:,:,:,:,:)
620  INTEGER(c_int) :: num_indices
621  num_indices = xt_idxlist_get_num_indices_c(xt_idxlist_f2c(idxlist))
622  IF (num_indices > SIZE(indices)) THEN
623  CALL xt_abort("indices array too small", filename, __line__)
624  END IF
625  CALL xt_idxlist_get_indices_c(xt_idxlist_f2c(idxlist), indices)
626  END SUBROUTINE xt_idxlist_get_indices_7d
627 
628  FUNCTION xt_idxlist_get_indices_const(idxlist) RESULT(indices)
629  TYPE(xt_idxlist), INTENT(in) :: idxlist
630  INTEGER(xt_int_kind), POINTER :: indices(:)
631  INTEGER(c_int) :: num_indices
632  TYPE(c_ptr) :: c_indices
633  INTEGER(xt_int_kind), SAVE, TARGET :: dummy(1) = -huge(indices)
634  INTEGER :: indices_shape(1)
635  INTERFACE
636  FUNCTION xt_idxlist_get_indices_const_c(idxlist) &
637  bind(c, name='xt_idxlist_get_indices_const') result(indices)
638  IMPORT :: c_ptr
639  IMPLICIT NONE
640  TYPE(c_ptr), VALUE, INTENT(in) :: idxlist
641  TYPE(c_ptr) :: indices
642  END FUNCTION xt_idxlist_get_indices_const_c
643  END INTERFACE
644  num_indices = xt_idxlist_get_num_indices_c(xt_idxlist_f2c(idxlist))
645  IF (num_indices > 0_xt_int_kind) THEN
646  IF (num_indices > huge(indices_shape)) &
647  CALL xt_abort("too many indices for default integer kind", &
648  filename, __line__)
649  indices_shape(1) = int(num_indices)
650  c_indices = xt_idxlist_get_indices_const_c(xt_idxlist_f2c(idxlist))
651  CALL c_f_pointer(c_indices, indices, indices_shape)
652  ELSE
653  indices => dummy(1:0)
654  END IF
655  END FUNCTION xt_idxlist_get_indices_const
656 
657  FUNCTION gpe_is_i4_a_i4_p1d_l(idxlist, &
658  num_stripes, stripes, num_ext, pos_ext, single_match_only) &
659  result(num_unmatched)
660  TYPE(xt_idxlist), INTENT(in) :: idxlist
661  INTEGER(i4), INTENT(in) :: num_stripes
662  TYPE(xt_stripe), INTENT(in), TARGET :: stripes(num_stripes)
663  INTEGER, INTENT(out) :: num_ext
664  TYPE(xt_pos_ext), ALLOCATABLE, INTENT(out) :: pos_ext(:)
665  LOGICAL, INTENT(in) :: single_match_only
666  INTEGER :: num_unmatched
667 
668  INTEGER(c_int) :: num_unmatched_c, num_ext_c, num_stripes_c
669  TYPE(c_ptr) :: pos_ext_c, stripes_c
670  TYPE(xt_pos_ext), POINTER :: pos_ext_fptr(:)
671  INTEGER :: pos_ext_shape(1)
672  TYPE(xt_pos_ext), TARGET :: dummy_stripe(1)
673 
674  IF (num_stripes > huge(1_c_int) .OR. num_stripes < 0) &
675  CALL xt_abort("interface violation detected", filename, __line__)
676 
677  IF (num_stripes > 0_i4) THEN
678  stripes_c = c_loc(stripes)
679  ELSE
680  stripes_c = c_loc(dummy_stripe)
681  END IF
682  num_stripes_c = int(num_stripes, c_int)
683  num_unmatched_c = xt_idxlist_get_pos_exts_of_index_stripes_c(&
684  xt_idxlist_f2c(idxlist), num_stripes_c, stripes_c, &
685  num_ext_c, pos_ext_c, merge(1_c_int, 0_c_int, single_match_only))
686 
687  IF (num_ext_c > huge(1) .OR. num_ext_c < 0 &
688  .OR. num_unmatched_c > huge(1) .OR. num_unmatched_c < 0) &
689  CALL xt_abort("data representation problem", filename, __line__)
690  num_unmatched = int(num_unmatched_c)
691  num_ext = int(num_ext_c)
692  IF (num_ext > 0) THEN
693  ALLOCATE(pos_ext(num_ext))
694  pos_ext_shape(1) = num_ext
695  CALL c_f_pointer(pos_ext_c, pos_ext_fptr, pos_ext_shape)
696  pos_ext = pos_ext_fptr
697  CALL free_c(pos_ext_c)
698  END IF
699  END FUNCTION gpe_is_i4_a_i4_p1d_l
700 
701  FUNCTION gpe_is_a_p1d_l(idxlist, stripes, pos_ext, single_match_only) &
702  result(num_unmatched)
703  TYPE(xt_idxlist), INTENT(in) :: idxlist
704  TYPE(xt_stripe), INTENT(in) :: stripes(:)
705  TYPE(xt_pos_ext), ALLOCATABLE, INTENT(out) :: pos_ext(:)
706  LOGICAL, INTENT(in) :: single_match_only
707  INTEGER :: num_unmatched
708 
709  INTEGER :: num_ext
710  INTEGER(i4) :: num_stripes
711 
712  num_stripes = SIZE(stripes)
713  IF (num_stripes > 0) THEN
714  num_unmatched = gpe_is_i4_a_i4_p1d_l(idxlist, num_stripes, stripes, &
715  num_ext, pos_ext, single_match_only)
716  ELSE
717  num_unmatched = 0
718  END IF
719  END FUNCTION gpe_is_a_p1d_l
720 
721 END MODULE xt_idxlist_abstract
722 !
723 ! Local Variables:
724 ! f90-continuation-indent: 5
725 ! coding: utf-8
726 ! indent-tabs-mode: nil
727 ! show-trailing-whitespace: t
728 ! require-trailing-newline: t
729 ! End:
730 !
integer, parameter, public i8
Definition: xt_core_f.f90:60
integer, parameter, public xt_int_kind
Definition: xt_core_f.f90:54
integer, parameter, public i4
Definition: xt_core_f.f90:59
integer, parameter, public i2
Definition: xt_core_f.f90:58
external, public xt_idxlist_unpack_f
external, public xt_idxlist_pack_f
type(xt_idxlist) function, public xt_idxlist_c2f(idxlist)
describes range of positions starting with start up to start + size - 1 i.e. [start,...
Definition: xt_core_f.f90:91
int xt_idxlist_get_num_indices(Xt_idxlist idxlist)
Definition: xt_idxlist.c:98
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:203
int xt_idxlist_get_index_at_position(Xt_idxlist idxlist, int position, Xt_int *index)
Definition: xt_idxlist.c:158
void xt_idxlist_get_indices(Xt_idxlist idxlist, Xt_int *indices)
Definition: xt_idxlist.c:102
int xt_idxlist_get_position_of_index_off(Xt_idxlist idxlist, Xt_int index, int *position, int offset)
Definition: xt_idxlist.c:264
size_t xt_idxlist_get_pack_size(Xt_idxlist idxlist, MPI_Comm comm)
Definition: xt_idxlist.c:79
int xt_idxlist_get_indices_at_positions(Xt_idxlist idxlist, const int *positions, int num_pos, Xt_int *indices, Xt_int undef_idx)
Definition: xt_idxlist.c:165
void xt_idxlist_get_index_stripes(Xt_idxlist idxlist, struct Xt_stripe **stripes, int *num_stripes)
Definition: xt_idxlist.c:118
void xt_idxlist_get_bounding_box(Xt_idxlist idxlist, unsigned ndim, const Xt_int global_size[ndim], Xt_int global_start_index, struct Xt_bounds bounds[ndim])
Definition: xt_idxlist.c:332
int xt_idxlist_get_pos_exts_of_index_stripes(Xt_idxlist idxlist, int num_stripes, const struct Xt_stripe stripes[num_stripes], int *num_ext, struct Xt_pos_ext **pos_ext, int single_match_only)
Definition: xt_idxlist.c:237
Xt_idxlist xt_idxlist_get_intersection(Xt_idxlist idxlist_src, Xt_idxlist idxlist_dst)
Xt_idxlist xt_idxlist_copy(Xt_idxlist idxlist)
Definition: xt_idxlist.c:93
const Xt_int * xt_idxlist_get_indices_const(Xt_idxlist idxlist)
Definition: xt_idxlist.c:108
int xt_idxlist_get_position_of_index(Xt_idxlist idxlist, Xt_int index, int *position)
Definition: xt_idxlist.c:196
void xt_idxlist_delete(Xt_idxlist idxlist)
Definition: xt_idxlist.c:74