]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Implementation of the MINLOC intrinsic |
85ec4feb | 2 | Copyright (C) 2002-2018 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Paul Brook <paul@nowt.org> |
4 | ||
57dea9f6 | 5 | This file is part of the GNU Fortran 95 runtime library (libgfortran). |
6de9cd9a DN |
6 | |
7 | Libgfortran is free software; you can redistribute it and/or | |
57dea9f6 | 8 | modify it under the terms of the GNU General Public |
6de9cd9a | 9 | License as published by the Free Software Foundation; either |
748086b7 | 10 | version 3 of the License, or (at your option) any later version. |
6de9cd9a DN |
11 | |
12 | Libgfortran is distributed in the hope that it will be useful, | |
13 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
57dea9f6 | 15 | GNU General Public License for more details. |
6de9cd9a | 16 | |
748086b7 JJ |
17 | Under Section 7 of GPL version 3, you are granted additional |
18 | permissions described in the GCC Runtime Library Exception, version | |
19 | 3.1, as published by the Free Software Foundation. | |
20 | ||
21 | You should have received a copy of the GNU General Public License and | |
22 | a copy of the GCC Runtime Library Exception along with this program; | |
23 | see the files COPYING3 and COPYING.RUNTIME respectively. If not, see | |
24 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a | 25 | |
36ae8a61 | 26 | #include "libgfortran.h" |
6de9cd9a DN |
27 | |
28 | ||
644cb69f FXC |
29 | #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_4) |
30 | ||
7d7b8bfe | 31 | |
64acfd99 JB |
32 | extern void minloc0_4_i8 (gfc_array_i4 * const restrict retarray, |
33 | gfc_array_i8 * const restrict array); | |
7f68c75f | 34 | export_proto(minloc0_4_i8); |
7d7b8bfe | 35 | |
6de9cd9a | 36 | void |
64acfd99 JB |
37 | minloc0_4_i8 (gfc_array_i4 * const restrict retarray, |
38 | gfc_array_i8 * const restrict array) | |
6de9cd9a DN |
39 | { |
40 | index_type count[GFC_MAX_DIMENSIONS]; | |
41 | index_type extent[GFC_MAX_DIMENSIONS]; | |
42 | index_type sstride[GFC_MAX_DIMENSIONS]; | |
43 | index_type dstride; | |
64acfd99 | 44 | const GFC_INTEGER_8 *base; |
5863aacf | 45 | GFC_INTEGER_4 * restrict dest; |
6de9cd9a DN |
46 | index_type rank; |
47 | index_type n; | |
48 | ||
49 | rank = GFC_DESCRIPTOR_RANK (array); | |
50dd63a9 TK |
50 | if (rank <= 0) |
51 | runtime_error ("Rank of array needs to be > 0"); | |
52 | ||
21d1335b | 53 | if (retarray->base_addr == NULL) |
50dd63a9 | 54 | { |
dfb55fdc | 55 | GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); |
50dd63a9 | 56 | retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; |
efd4dc1a | 57 | retarray->offset = 0; |
92e6f3a4 | 58 | retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); |
50dd63a9 TK |
59 | } |
60 | else | |
61 | { | |
9731c4a3 | 62 | if (unlikely (compile_options.bounds_check)) |
80927a56 JJ |
63 | bounds_iforeach_return ((array_t *) retarray, (array_t *) array, |
64 | "MINLOC"); | |
50dd63a9 | 65 | } |
e33e218b | 66 | |
dfb55fdc | 67 | dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); |
21d1335b | 68 | dest = retarray->base_addr; |
6de9cd9a DN |
69 | for (n = 0; n < rank; n++) |
70 | { | |
dfb55fdc TK |
71 | sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); |
72 | extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); | |
6de9cd9a DN |
73 | count[n] = 0; |
74 | if (extent[n] <= 0) | |
75 | { | |
76 | /* Set the return value. */ | |
77 | for (n = 0; n < rank; n++) | |
78 | dest[n * dstride] = 0; | |
79 | return; | |
80 | } | |
81 | } | |
82 | ||
21d1335b | 83 | base = array->base_addr; |
6de9cd9a DN |
84 | |
85 | /* Initialize the return value. */ | |
86 | for (n = 0; n < rank; n++) | |
80927a56 | 87 | dest[n * dstride] = 1; |
6de9cd9a DN |
88 | { |
89 | ||
80927a56 JJ |
90 | GFC_INTEGER_8 minval; |
91 | #if defined(GFC_INTEGER_8_QUIET_NAN) | |
92 | int fast = 0; | |
93 | #endif | |
6de9cd9a | 94 | |
80927a56 JJ |
95 | #if defined(GFC_INTEGER_8_INFINITY) |
96 | minval = GFC_INTEGER_8_INFINITY; | |
97 | #else | |
98 | minval = GFC_INTEGER_8_HUGE; | |
99 | #endif | |
6de9cd9a DN |
100 | while (base) |
101 | { | |
80927a56 JJ |
102 | do |
103 | { | |
104 | /* Implementation start. */ | |
6de9cd9a | 105 | |
80927a56 JJ |
106 | #if defined(GFC_INTEGER_8_QUIET_NAN) |
107 | } | |
108 | while (0); | |
109 | if (unlikely (!fast)) | |
110 | { | |
111 | do | |
112 | { | |
113 | if (*base <= minval) | |
114 | { | |
115 | fast = 1; | |
116 | minval = *base; | |
117 | for (n = 0; n < rank; n++) | |
118 | dest[n * dstride] = count[n] + 1; | |
119 | break; | |
120 | } | |
121 | base += sstride[0]; | |
122 | } | |
123 | while (++count[0] != extent[0]); | |
124 | if (likely (fast)) | |
125 | continue; | |
126 | } | |
127 | else do | |
128 | { | |
129 | #endif | |
130 | if (*base < minval) | |
131 | { | |
132 | minval = *base; | |
133 | for (n = 0; n < rank; n++) | |
134 | dest[n * dstride] = count[n] + 1; | |
135 | } | |
136 | /* Implementation end. */ | |
137 | /* Advance to the next element. */ | |
138 | base += sstride[0]; | |
139 | } | |
140 | while (++count[0] != extent[0]); | |
6de9cd9a | 141 | n = 0; |
80927a56 JJ |
142 | do |
143 | { | |
144 | /* When we get to the end of a dimension, reset it and increment | |
145 | the next dimension. */ | |
146 | count[n] = 0; | |
147 | /* We could precalculate these products, but this is a less | |
148 | frequently used path so probably not worth it. */ | |
149 | base -= sstride[n] * extent[n]; | |
150 | n++; | |
80dd631f | 151 | if (n >= rank) |
80927a56 JJ |
152 | { |
153 | /* Break out of the loop. */ | |
154 | base = NULL; | |
155 | break; | |
156 | } | |
157 | else | |
158 | { | |
159 | count[n]++; | |
160 | base += sstride[n]; | |
161 | } | |
162 | } | |
163 | while (count[n] == extent[n]); | |
6de9cd9a DN |
164 | } |
165 | } | |
166 | } | |
167 | ||
7d7b8bfe | 168 | |
64acfd99 | 169 | extern void mminloc0_4_i8 (gfc_array_i4 * const restrict, |
28dc6b33 | 170 | gfc_array_i8 * const restrict, gfc_array_l1 * const restrict); |
7f68c75f | 171 | export_proto(mminloc0_4_i8); |
7d7b8bfe | 172 | |
6de9cd9a | 173 | void |
64acfd99 JB |
174 | mminloc0_4_i8 (gfc_array_i4 * const restrict retarray, |
175 | gfc_array_i8 * const restrict array, | |
28dc6b33 | 176 | gfc_array_l1 * const restrict mask) |
6de9cd9a DN |
177 | { |
178 | index_type count[GFC_MAX_DIMENSIONS]; | |
179 | index_type extent[GFC_MAX_DIMENSIONS]; | |
180 | index_type sstride[GFC_MAX_DIMENSIONS]; | |
181 | index_type mstride[GFC_MAX_DIMENSIONS]; | |
182 | index_type dstride; | |
183 | GFC_INTEGER_4 *dest; | |
64acfd99 | 184 | const GFC_INTEGER_8 *base; |
28dc6b33 | 185 | GFC_LOGICAL_1 *mbase; |
6de9cd9a DN |
186 | int rank; |
187 | index_type n; | |
28dc6b33 | 188 | int mask_kind; |
6de9cd9a DN |
189 | |
190 | rank = GFC_DESCRIPTOR_RANK (array); | |
50dd63a9 TK |
191 | if (rank <= 0) |
192 | runtime_error ("Rank of array needs to be > 0"); | |
193 | ||
21d1335b | 194 | if (retarray->base_addr == NULL) |
50dd63a9 | 195 | { |
dfb55fdc | 196 | GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1); |
50dd63a9 | 197 | retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; |
efd4dc1a | 198 | retarray->offset = 0; |
92e6f3a4 | 199 | retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); |
50dd63a9 TK |
200 | } |
201 | else | |
202 | { | |
9731c4a3 | 203 | if (unlikely (compile_options.bounds_check)) |
fd6590f8 | 204 | { |
16bff921 TK |
205 | |
206 | bounds_iforeach_return ((array_t *) retarray, (array_t *) array, | |
207 | "MINLOC"); | |
208 | bounds_equal_extents ((array_t *) mask, (array_t *) array, | |
209 | "MASK argument", "MINLOC"); | |
fd6590f8 | 210 | } |
50dd63a9 | 211 | } |
6de9cd9a | 212 | |
28dc6b33 TK |
213 | mask_kind = GFC_DESCRIPTOR_SIZE (mask); |
214 | ||
21d1335b | 215 | mbase = mask->base_addr; |
28dc6b33 TK |
216 | |
217 | if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 | |
218 | #ifdef HAVE_GFC_LOGICAL_16 | |
219 | || mask_kind == 16 | |
220 | #endif | |
221 | ) | |
222 | mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); | |
223 | else | |
224 | runtime_error ("Funny sized logical array"); | |
225 | ||
dfb55fdc | 226 | dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); |
21d1335b | 227 | dest = retarray->base_addr; |
6de9cd9a DN |
228 | for (n = 0; n < rank; n++) |
229 | { | |
dfb55fdc TK |
230 | sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); |
231 | mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); | |
232 | extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); | |
6de9cd9a DN |
233 | count[n] = 0; |
234 | if (extent[n] <= 0) | |
235 | { | |
236 | /* Set the return value. */ | |
237 | for (n = 0; n < rank; n++) | |
238 | dest[n * dstride] = 0; | |
239 | return; | |
240 | } | |
241 | } | |
242 | ||
21d1335b | 243 | base = array->base_addr; |
6de9cd9a DN |
244 | |
245 | /* Initialize the return value. */ | |
246 | for (n = 0; n < rank; n++) | |
a4b9e93e | 247 | dest[n * dstride] = 0; |
6de9cd9a DN |
248 | { |
249 | ||
250 | GFC_INTEGER_8 minval; | |
80927a56 | 251 | int fast = 0; |
6de9cd9a | 252 | |
80927a56 JJ |
253 | #if defined(GFC_INTEGER_8_INFINITY) |
254 | minval = GFC_INTEGER_8_INFINITY; | |
255 | #else | |
256 | minval = GFC_INTEGER_8_HUGE; | |
257 | #endif | |
6de9cd9a DN |
258 | while (base) |
259 | { | |
80927a56 JJ |
260 | do |
261 | { | |
262 | /* Implementation start. */ | |
6de9cd9a | 263 | |
80927a56 JJ |
264 | } |
265 | while (0); | |
266 | if (unlikely (!fast)) | |
267 | { | |
268 | do | |
269 | { | |
270 | if (*mbase) | |
271 | { | |
272 | #if defined(GFC_INTEGER_8_QUIET_NAN) | |
273 | if (unlikely (dest[0] == 0)) | |
274 | for (n = 0; n < rank; n++) | |
275 | dest[n * dstride] = count[n] + 1; | |
276 | if (*base <= minval) | |
277 | #endif | |
278 | { | |
279 | fast = 1; | |
280 | minval = *base; | |
281 | for (n = 0; n < rank; n++) | |
282 | dest[n * dstride] = count[n] + 1; | |
283 | break; | |
284 | } | |
285 | } | |
286 | base += sstride[0]; | |
287 | mbase += mstride[0]; | |
288 | } | |
289 | while (++count[0] != extent[0]); | |
290 | if (likely (fast)) | |
291 | continue; | |
292 | } | |
293 | else do | |
294 | { | |
295 | if (*mbase && *base < minval) | |
296 | { | |
297 | minval = *base; | |
298 | for (n = 0; n < rank; n++) | |
299 | dest[n * dstride] = count[n] + 1; | |
300 | } | |
301 | /* Implementation end. */ | |
302 | /* Advance to the next element. */ | |
303 | base += sstride[0]; | |
304 | mbase += mstride[0]; | |
305 | } | |
306 | while (++count[0] != extent[0]); | |
6de9cd9a | 307 | n = 0; |
80927a56 JJ |
308 | do |
309 | { | |
310 | /* When we get to the end of a dimension, reset it and increment | |
311 | the next dimension. */ | |
312 | count[n] = 0; | |
313 | /* We could precalculate these products, but this is a less | |
314 | frequently used path so probably not worth it. */ | |
315 | base -= sstride[n] * extent[n]; | |
316 | mbase -= mstride[n] * extent[n]; | |
317 | n++; | |
80dd631f | 318 | if (n >= rank) |
80927a56 JJ |
319 | { |
320 | /* Break out of the loop. */ | |
321 | base = NULL; | |
322 | break; | |
323 | } | |
324 | else | |
325 | { | |
326 | count[n]++; | |
327 | base += sstride[n]; | |
328 | mbase += mstride[n]; | |
329 | } | |
330 | } | |
331 | while (count[n] == extent[n]); | |
6de9cd9a DN |
332 | } |
333 | } | |
334 | } | |
644cb69f | 335 | |
97a62038 TK |
336 | |
337 | extern void sminloc0_4_i8 (gfc_array_i4 * const restrict, | |
338 | gfc_array_i8 * const restrict, GFC_LOGICAL_4 *); | |
339 | export_proto(sminloc0_4_i8); | |
340 | ||
341 | void | |
342 | sminloc0_4_i8 (gfc_array_i4 * const restrict retarray, | |
343 | gfc_array_i8 * const restrict array, | |
344 | GFC_LOGICAL_4 * mask) | |
345 | { | |
346 | index_type rank; | |
347 | index_type dstride; | |
348 | index_type n; | |
349 | GFC_INTEGER_4 *dest; | |
350 | ||
351 | if (*mask) | |
352 | { | |
353 | minloc0_4_i8 (retarray, array); | |
354 | return; | |
355 | } | |
356 | ||
357 | rank = GFC_DESCRIPTOR_RANK (array); | |
358 | ||
359 | if (rank <= 0) | |
360 | runtime_error ("Rank of array needs to be > 0"); | |
361 | ||
21d1335b | 362 | if (retarray->base_addr == NULL) |
97a62038 | 363 | { |
dfb55fdc | 364 | GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1); |
97a62038 TK |
365 | retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1; |
366 | retarray->offset = 0; | |
92e6f3a4 | 367 | retarray->base_addr = xmallocarray (rank, sizeof (GFC_INTEGER_4)); |
97a62038 | 368 | } |
16bff921 | 369 | else if (unlikely (compile_options.bounds_check)) |
97a62038 | 370 | { |
16bff921 TK |
371 | bounds_iforeach_return ((array_t *) retarray, (array_t *) array, |
372 | "MINLOC"); | |
97a62038 TK |
373 | } |
374 | ||
dfb55fdc | 375 | dstride = GFC_DESCRIPTOR_STRIDE(retarray,0); |
21d1335b | 376 | dest = retarray->base_addr; |
97a62038 TK |
377 | for (n = 0; n<rank; n++) |
378 | dest[n * dstride] = 0 ; | |
379 | } | |
644cb69f | 380 | #endif |