Daily bump.
[official-gcc.git] / libgfortran / generated / minloc1_4_i1.c
blob92496affb0039270e423795630f41e3fc68d324a
1 /* Implementation of the MINLOC intrinsic
2 Copyright (C) 2002-2018 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
27 #include <assert.h>
30 #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_4)
32 #define HAVE_BACK_ARG 1
35 extern void minloc1_4_i1 (gfc_array_i4 * const restrict,
36 gfc_array_i1 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
37 export_proto(minloc1_4_i1);
39 void
40 minloc1_4_i1 (gfc_array_i4 * const restrict retarray,
41 gfc_array_i1 * const restrict array,
42 const index_type * const restrict pdim, GFC_LOGICAL_4 back)
44 index_type count[GFC_MAX_DIMENSIONS];
45 index_type extent[GFC_MAX_DIMENSIONS];
46 index_type sstride[GFC_MAX_DIMENSIONS];
47 index_type dstride[GFC_MAX_DIMENSIONS];
48 const GFC_INTEGER_1 * restrict base;
49 GFC_INTEGER_4 * restrict dest;
50 index_type rank;
51 index_type n;
52 index_type len;
53 index_type delta;
54 index_type dim;
55 int continue_loop;
57 /* Make dim zero based to avoid confusion. */
58 rank = GFC_DESCRIPTOR_RANK (array) - 1;
59 dim = (*pdim) - 1;
61 if (unlikely (dim < 0 || dim > rank))
63 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
64 "is %ld, should be between 1 and %ld",
65 (long int) dim + 1, (long int) rank + 1);
68 len = GFC_DESCRIPTOR_EXTENT(array,dim);
69 if (len < 0)
70 len = 0;
71 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
73 for (n = 0; n < dim; n++)
75 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
76 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
78 if (extent[n] < 0)
79 extent[n] = 0;
81 for (n = dim; n < rank; n++)
83 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
84 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
86 if (extent[n] < 0)
87 extent[n] = 0;
90 if (retarray->base_addr == NULL)
92 size_t alloc_size, str;
94 for (n = 0; n < rank; n++)
96 if (n == 0)
97 str = 1;
98 else
99 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
101 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
105 retarray->offset = 0;
106 retarray->dtype.rank = rank;
108 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
110 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
111 if (alloc_size == 0)
113 /* Make sure we have a zero-sized array. */
114 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
115 return;
119 else
121 if (rank != GFC_DESCRIPTOR_RANK (retarray))
122 runtime_error ("rank of return array incorrect in"
123 " MINLOC intrinsic: is %ld, should be %ld",
124 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
125 (long int) rank);
127 if (unlikely (compile_options.bounds_check))
128 bounds_ifunction_return ((array_t *) retarray, extent,
129 "return value", "MINLOC");
132 for (n = 0; n < rank; n++)
134 count[n] = 0;
135 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
136 if (extent[n] <= 0)
137 return;
140 base = array->base_addr;
141 dest = retarray->base_addr;
143 continue_loop = 1;
144 while (continue_loop)
146 const GFC_INTEGER_1 * restrict src;
147 GFC_INTEGER_4 result;
148 src = base;
151 GFC_INTEGER_1 minval;
152 #if defined (GFC_INTEGER_1_INFINITY)
153 minval = GFC_INTEGER_1_INFINITY;
154 #else
155 minval = GFC_INTEGER_1_HUGE;
156 #endif
157 result = 1;
158 if (len <= 0)
159 *dest = 0;
160 else
162 #if ! defined HAVE_BACK_ARG
163 for (n = 0; n < len; n++, src += delta)
165 #endif
167 #if defined (GFC_INTEGER_1_QUIET_NAN)
168 for (n = 0; n < len; n++, src += delta)
170 if (*src <= minval)
172 minval = *src;
173 result = (GFC_INTEGER_4)n + 1;
174 break;
177 #else
178 n = 0;
179 #endif
180 if (back)
181 for (; n < len; n++, src += delta)
183 if (unlikely (*src <= minval))
185 minval = *src;
186 result = (GFC_INTEGER_4)n + 1;
189 else
190 for (; n < len; n++, src += delta)
192 if (unlikely (*src < minval))
194 minval = *src;
195 result = (GFC_INTEGER_4) n + 1;
199 *dest = result;
202 /* Advance to the next element. */
203 count[0]++;
204 base += sstride[0];
205 dest += dstride[0];
206 n = 0;
207 while (count[n] == extent[n])
209 /* When we get to the end of a dimension, reset it and increment
210 the next dimension. */
211 count[n] = 0;
212 /* We could precalculate these products, but this is a less
213 frequently used path so probably not worth it. */
214 base -= sstride[n] * extent[n];
215 dest -= dstride[n] * extent[n];
216 n++;
217 if (n >= rank)
219 /* Break out of the loop. */
220 continue_loop = 0;
221 break;
223 else
225 count[n]++;
226 base += sstride[n];
227 dest += dstride[n];
234 extern void mminloc1_4_i1 (gfc_array_i4 * const restrict,
235 gfc_array_i1 * const restrict, const index_type * const restrict,
236 gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
237 export_proto(mminloc1_4_i1);
239 void
240 mminloc1_4_i1 (gfc_array_i4 * const restrict retarray,
241 gfc_array_i1 * const restrict array,
242 const index_type * const restrict pdim,
243 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
245 index_type count[GFC_MAX_DIMENSIONS];
246 index_type extent[GFC_MAX_DIMENSIONS];
247 index_type sstride[GFC_MAX_DIMENSIONS];
248 index_type dstride[GFC_MAX_DIMENSIONS];
249 index_type mstride[GFC_MAX_DIMENSIONS];
250 GFC_INTEGER_4 * restrict dest;
251 const GFC_INTEGER_1 * restrict base;
252 const GFC_LOGICAL_1 * restrict mbase;
253 index_type rank;
254 index_type dim;
255 index_type n;
256 index_type len;
257 index_type delta;
258 index_type mdelta;
259 int mask_kind;
261 dim = (*pdim) - 1;
262 rank = GFC_DESCRIPTOR_RANK (array) - 1;
265 if (unlikely (dim < 0 || dim > rank))
267 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
268 "is %ld, should be between 1 and %ld",
269 (long int) dim + 1, (long int) rank + 1);
272 len = GFC_DESCRIPTOR_EXTENT(array,dim);
273 if (len <= 0)
274 return;
276 mbase = mask->base_addr;
278 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
280 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
281 #ifdef HAVE_GFC_LOGICAL_16
282 || mask_kind == 16
283 #endif
285 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
286 else
287 runtime_error ("Funny sized logical array");
289 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
290 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
292 for (n = 0; n < dim; n++)
294 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
295 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
296 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
298 if (extent[n] < 0)
299 extent[n] = 0;
302 for (n = dim; n < rank; n++)
304 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
305 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
306 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
308 if (extent[n] < 0)
309 extent[n] = 0;
312 if (retarray->base_addr == NULL)
314 size_t alloc_size, str;
316 for (n = 0; n < rank; n++)
318 if (n == 0)
319 str = 1;
320 else
321 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
323 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
327 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
329 retarray->offset = 0;
330 retarray->dtype.rank = rank;
332 if (alloc_size == 0)
334 /* Make sure we have a zero-sized array. */
335 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
336 return;
338 else
339 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
342 else
344 if (rank != GFC_DESCRIPTOR_RANK (retarray))
345 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
347 if (unlikely (compile_options.bounds_check))
349 bounds_ifunction_return ((array_t *) retarray, extent,
350 "return value", "MINLOC");
351 bounds_equal_extents ((array_t *) mask, (array_t *) array,
352 "MASK argument", "MINLOC");
356 for (n = 0; n < rank; n++)
358 count[n] = 0;
359 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
360 if (extent[n] <= 0)
361 return;
364 dest = retarray->base_addr;
365 base = array->base_addr;
367 while (base)
369 const GFC_INTEGER_1 * restrict src;
370 const GFC_LOGICAL_1 * restrict msrc;
371 GFC_INTEGER_4 result;
372 src = base;
373 msrc = mbase;
376 GFC_INTEGER_1 minval;
377 #if defined (GFC_INTEGER_1_INFINITY)
378 minval = GFC_INTEGER_1_INFINITY;
379 #else
380 minval = GFC_INTEGER_1_HUGE;
381 #endif
382 #if defined (GFC_INTEGER_1_QUIET_NAN)
383 GFC_INTEGER_4 result2 = 0;
384 #endif
385 result = 0;
386 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
389 if (*msrc)
391 #if defined (GFC_INTEGER_1_QUIET_NAN)
392 if (!result2)
393 result2 = (GFC_INTEGER_4)n + 1;
394 if (*src <= minval)
395 #endif
397 minval = *src;
398 result = (GFC_INTEGER_4)n + 1;
399 break;
403 #if defined (GFC_INTEGER_1_QUIET_NAN)
404 if (unlikely (n >= len))
405 result = result2;
406 else
407 #endif
408 if (back)
409 for (; n < len; n++, src += delta, msrc += mdelta)
411 if (*msrc && unlikely (*src <= minval))
413 minval = *src;
414 result = (GFC_INTEGER_4)n + 1;
417 else
418 for (; n < len; n++, src += delta, msrc += mdelta)
420 if (*msrc && unlikely (*src < minval))
422 minval = *src;
423 result = (GFC_INTEGER_4) n + 1;
426 *dest = result;
428 /* Advance to the next element. */
429 count[0]++;
430 base += sstride[0];
431 mbase += mstride[0];
432 dest += dstride[0];
433 n = 0;
434 while (count[n] == extent[n])
436 /* When we get to the end of a dimension, reset it and increment
437 the next dimension. */
438 count[n] = 0;
439 /* We could precalculate these products, but this is a less
440 frequently used path so probably not worth it. */
441 base -= sstride[n] * extent[n];
442 mbase -= mstride[n] * extent[n];
443 dest -= dstride[n] * extent[n];
444 n++;
445 if (n >= rank)
447 /* Break out of the loop. */
448 base = NULL;
449 break;
451 else
453 count[n]++;
454 base += sstride[n];
455 mbase += mstride[n];
456 dest += dstride[n];
463 extern void sminloc1_4_i1 (gfc_array_i4 * const restrict,
464 gfc_array_i1 * const restrict, const index_type * const restrict,
465 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
466 export_proto(sminloc1_4_i1);
468 void
469 sminloc1_4_i1 (gfc_array_i4 * const restrict retarray,
470 gfc_array_i1 * const restrict array,
471 const index_type * const restrict pdim,
472 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
474 index_type count[GFC_MAX_DIMENSIONS];
475 index_type extent[GFC_MAX_DIMENSIONS];
476 index_type dstride[GFC_MAX_DIMENSIONS];
477 GFC_INTEGER_4 * restrict dest;
478 index_type rank;
479 index_type n;
480 index_type dim;
483 if (*mask)
485 #ifdef HAVE_BACK_ARG
486 minloc1_4_i1 (retarray, array, pdim, back);
487 #else
488 minloc1_4_i1 (retarray, array, pdim);
489 #endif
490 return;
492 /* Make dim zero based to avoid confusion. */
493 dim = (*pdim) - 1;
494 rank = GFC_DESCRIPTOR_RANK (array) - 1;
496 if (unlikely (dim < 0 || dim > rank))
498 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
499 "is %ld, should be between 1 and %ld",
500 (long int) dim + 1, (long int) rank + 1);
503 for (n = 0; n < dim; n++)
505 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
507 if (extent[n] <= 0)
508 extent[n] = 0;
511 for (n = dim; n < rank; n++)
513 extent[n] =
514 GFC_DESCRIPTOR_EXTENT(array,n + 1);
516 if (extent[n] <= 0)
517 extent[n] = 0;
520 if (retarray->base_addr == NULL)
522 size_t alloc_size, str;
524 for (n = 0; n < rank; n++)
526 if (n == 0)
527 str = 1;
528 else
529 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
531 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
535 retarray->offset = 0;
536 retarray->dtype.rank = rank;
538 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
540 if (alloc_size == 0)
542 /* Make sure we have a zero-sized array. */
543 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
544 return;
546 else
547 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4));
549 else
551 if (rank != GFC_DESCRIPTOR_RANK (retarray))
552 runtime_error ("rank of return array incorrect in"
553 " MINLOC intrinsic: is %ld, should be %ld",
554 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
555 (long int) rank);
557 if (unlikely (compile_options.bounds_check))
559 for (n=0; n < rank; n++)
561 index_type ret_extent;
563 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
564 if (extent[n] != ret_extent)
565 runtime_error ("Incorrect extent in return value of"
566 " MINLOC intrinsic in dimension %ld:"
567 " is %ld, should be %ld", (long int) n + 1,
568 (long int) ret_extent, (long int) extent[n]);
573 for (n = 0; n < rank; n++)
575 count[n] = 0;
576 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
579 dest = retarray->base_addr;
581 while(1)
583 *dest = 0;
584 count[0]++;
585 dest += dstride[0];
586 n = 0;
587 while (count[n] == extent[n])
589 /* When we get to the end of a dimension, reset it and increment
590 the next dimension. */
591 count[n] = 0;
592 /* We could precalculate these products, but this is a less
593 frequently used path so probably not worth it. */
594 dest -= dstride[n] * extent[n];
595 n++;
596 if (n >= rank)
597 return;
598 else
600 count[n]++;
601 dest += dstride[n];
607 #endif