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