Yet Another eXchange Tool 0.11.4
Loading...
Searching...
No Matches
xt_idxsection_f.f90
Go to the documentation of this file.
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://dkrz-sw.gitlab-pages.dkrz.de/yaxt/
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#include "fc_feature_defs.inc"
48MODULE xt_idxsection
49 USE iso_c_binding, ONLY: c_int, c_ptr
50 USE xt_core, ONLY: xt_int_kind, xt_abort, i2, i4, i8
51 USE xt_idxlist_abstract, ONLY: xt_idxlist, xt_idxlist_c2f
52 IMPLICIT NONE
53 PRIVATE
54 PUBLIC :: xt_idxsection_new, xt_idxfsection_new
55
56 INTERFACE xt_idxsection_new
57 MODULE PROCEDURE xt_idxsection_new_a
58 MODULE PROCEDURE xt_idxsection_new_i2
59 MODULE PROCEDURE xt_idxsection_new_i4
60 MODULE PROCEDURE xt_idxsection_new_i8
61 END INTERFACE xt_idxsection_new
62
63 INTERFACE
64 FUNCTION xt_idxsection_new_c(start, num_dimensions, global_size, &
65 local_size, local_start) bind(c, name='xt_idxsection_new') &
66 result(idxsection)
67 IMPORT :: c_int, c_ptr, xt_idxlist, xt_int_kind
68 INTEGER(xt_int_kind), VALUE, INTENT(in) :: start
69 INTEGER(c_int), VALUE, INTENT(in) :: num_dimensions
70 INTEGER(xt_int_kind), INTENT(in) :: global_size(num_dimensions), &
71 local_start(num_dimensions)
72 INTEGER(c_int), INTENT(in) :: local_size(num_dimensions)
73 TYPE(c_ptr) :: idxsection
74 END FUNCTION xt_idxsection_new_c
75 END INTERFACE
76
77 CHARACTER(len=*), PARAMETER :: filename = 'xt_idxsection_f.f90'
78CONTAINS
79
80 FUNCTION xt_idxsection_new_a(start, global_size, local_size, local_start) &
81 result(idxsection)
82 INTEGER(xt_int_kind), INTENT(in) :: start, local_start(:), global_size(:)
83 INTEGER, INTENT(in) :: local_size(:)
84 TYPE(xt_idxlist) :: idxsection
85 INTEGER :: num_dimensions
86 INTEGER(c_int) :: num_dimensions_c
87 num_dimensions = SIZE(global_size)
88 IF (SIZE(local_size) /= num_dimensions &
89 .OR. SIZE(local_start) /= num_dimensions) &
90 CALL xt_abort("non-matching array sizes", filename, __line__)
91 num_dimensions_c = int(num_dimensions, c_int)
92 idxsection = xt_idxlist_c2f(&
93 xt_idxsection_new_c(start, num_dimensions_c, global_size, &
94 & int(local_size, c_int), local_start))
95 END FUNCTION xt_idxsection_new_a
96
97 FUNCTION xt_idxsection_new_i2(start, num_dimensions, global_size, &
98 local_size, local_start) RESULT(idxsection)
99 INTEGER(i2), INTENT(in) :: num_dimensions
100 INTEGER(xt_int_kind), INTENT(in) :: start, global_size(num_dimensions), &
101 local_start(num_dimensions)
102 INTEGER, INTENT(in) :: local_size(num_dimensions)
103 TYPE(xt_idxlist) :: idxsection
104 INTEGER(c_int) :: num_dimensions_c
105
106 num_dimensions_c = int(num_dimensions, c_int)
107 idxsection = xt_idxlist_c2f(&
108 xt_idxsection_new_c(start, num_dimensions_c, global_size, &
109 & int(local_size, c_int), local_start))
110 END FUNCTION xt_idxsection_new_i2
111
112 FUNCTION xt_idxsection_new_i4(start, num_dimensions, global_size, &
113 local_size, local_start) RESULT(idxsection)
114 INTEGER(i4), INTENT(in) :: num_dimensions
115 INTEGER(xt_int_kind), INTENT(in) :: start, global_size(num_dimensions), &
116 local_start(num_dimensions)
117 INTEGER, INTENT(in) :: local_size(num_dimensions)
118 TYPE(xt_idxlist) :: idxsection
119 INTEGER(c_int), PARAMETER :: dummy = 1
120 INTEGER(c_int) :: num_dimensions_c
121
122 IF (num_dimensions > huge(dummy)) &
123 CALL xt_abort("num_dimensions too large", filename, __line__)
124 num_dimensions_c = int(num_dimensions, c_int)
125 idxsection = xt_idxlist_c2f(&
126 xt_idxsection_new_c(start, num_dimensions_c, global_size, &
127 & int(local_size, c_int), local_start))
128 END FUNCTION xt_idxsection_new_i4
129
130 FUNCTION xt_idxsection_new_i8(start, num_dimensions, global_size, &
131 local_size, local_start) RESULT(idxsection)
132 INTEGER(i8), INTENT(in) :: num_dimensions
133 INTEGER(xt_int_kind), INTENT(in) :: start, global_size(num_dimensions), &
134 local_start(num_dimensions)
135 INTEGER, INTENT(in) :: local_size(num_dimensions)
136 TYPE(xt_idxlist) :: idxsection
137 INTEGER(c_int), PARAMETER :: dummy = 1
138 INTEGER(c_int) :: num_dimensions_c
139
140 IF (num_dimensions > huge(dummy)) &
141 CALL xt_abort("num_dimensions too large", filename, __line__)
142 num_dimensions_c = int(num_dimensions, c_int)
143 idxsection = xt_idxlist_c2f(&
144 xt_idxsection_new_c(start, num_dimensions_c, global_size, &
145 & int(local_size, c_int), local_start))
146 END FUNCTION xt_idxsection_new_i8
147
157 FUNCTION xt_idxfsection_new(start, global_size, local_size, local_start) &
158 result(idxfsection)
159 INTEGER(xt_int_kind), INTENT(in) :: start, global_size(:), local_start(:)
160 INTEGER, INTENT(in) :: local_size(:)
161 TYPE(xt_idxlist) :: idxfsection
162
163 INTEGER :: idim, ndim
164 LOGICAL :: err_state
165
166 ndim = SIZE(global_size)
167 IF (SIZE(local_size) /= ndim .OR. SIZE(local_start) /= ndim) &
168 CALL xt_abort("non-matching array sizes", filename, __line__)
169
170 ! check if local indices are a subset of global indices:
171 err_state = .false.
172 DO idim = 1, ndim
173 err_state = err_state .OR. (local_start(idim) < 1) .OR. &
174 (local_start(idim) + local_size(idim) - 1 > global_size(idim))
175 ENDDO
176 IF (err_state) CALL xt_abort("local indices out of global index space", &
177 filename, __line__)
178
179 ! Fortran style map of mult-dim coords to indices:
180 ! => reverse order of dimensions and coords starting at 1 (instead of 0 as in c)
181 idxfsection = xt_idxsection_new(start, &
182 global_size(ndim:1:-1), &
183 local_size(ndim:1:-1), &
184 local_start(ndim:1:-1) - 1_xt_int_kind )
185
186 END FUNCTION xt_idxfsection_new
187
188END MODULE xt_idxsection
189!
190! Local Variables:
191! f90-continuation-indent: 5
192! coding: utf-8
193! indent-tabs-mode: nil
194! show-trailing-whitespace: t
195! require-trailing-newline: t
196! End:
197!
Xt_idxlist xt_idxsection_new(Xt_int start, int num_dimensions, const Xt_int global_size[num_dimensions], const int local_size[num_dimensions], const Xt_int local_start[num_dimensions])