Daily bump.
[official-gcc.git] / libgfortran / generated / maxloc1_8_i8.c
blob312467586f5a70369bfcce5b395870ace5341411
1 /* Implementation of the MAXLOC 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_8) && defined (HAVE_GFC_INTEGER_8)
32 #define HAVE_BACK_ARG 1
35 extern void maxloc1_8_i8 (gfc_array_i8 * const restrict,
36 gfc_array_i8 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
37 export_proto(maxloc1_8_i8);
39 void
40 maxloc1_8_i8 (gfc_array_i8 * const restrict retarray,
41 gfc_array_i8 * 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_8 * restrict base;
49 GFC_INTEGER_8 * 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 MAXLOC 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_8));
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 " MAXLOC 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", "MAXLOC");
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_8 * restrict src;
147 GFC_INTEGER_8 result;
148 src = base;
151 GFC_INTEGER_8 maxval;
152 #if defined (GFC_INTEGER_8_INFINITY)
153 maxval = -GFC_INTEGER_8_INFINITY;
154 #else
155 maxval = (-GFC_INTEGER_8_HUGE-1);
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_8_QUIET_NAN)
168 for (n = 0; n < len; n++, src += delta)
170 if (*src >= maxval)
172 maxval = *src;
173 result = (GFC_INTEGER_8)n + 1;
174 break;
177 #else
178 n = 0;
179 #endif
180 for (; n < len; n++, src += delta)
182 if (back ? *src >= maxval : *src > maxval)
184 maxval = *src;
185 result = (GFC_INTEGER_8)n + 1;
189 *dest = result;
192 /* Advance to the next element. */
193 count[0]++;
194 base += sstride[0];
195 dest += dstride[0];
196 n = 0;
197 while (count[n] == extent[n])
199 /* When we get to the end of a dimension, reset it and increment
200 the next dimension. */
201 count[n] = 0;
202 /* We could precalculate these products, but this is a less
203 frequently used path so probably not worth it. */
204 base -= sstride[n] * extent[n];
205 dest -= dstride[n] * extent[n];
206 n++;
207 if (n >= rank)
209 /* Break out of the loop. */
210 continue_loop = 0;
211 break;
213 else
215 count[n]++;
216 base += sstride[n];
217 dest += dstride[n];
224 extern void mmaxloc1_8_i8 (gfc_array_i8 * const restrict,
225 gfc_array_i8 * const restrict, const index_type * const restrict,
226 gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
227 export_proto(mmaxloc1_8_i8);
229 void
230 mmaxloc1_8_i8 (gfc_array_i8 * const restrict retarray,
231 gfc_array_i8 * const restrict array,
232 const index_type * const restrict pdim,
233 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
235 index_type count[GFC_MAX_DIMENSIONS];
236 index_type extent[GFC_MAX_DIMENSIONS];
237 index_type sstride[GFC_MAX_DIMENSIONS];
238 index_type dstride[GFC_MAX_DIMENSIONS];
239 index_type mstride[GFC_MAX_DIMENSIONS];
240 GFC_INTEGER_8 * restrict dest;
241 const GFC_INTEGER_8 * restrict base;
242 const GFC_LOGICAL_1 * restrict mbase;
243 index_type rank;
244 index_type dim;
245 index_type n;
246 index_type len;
247 index_type delta;
248 index_type mdelta;
249 int mask_kind;
251 dim = (*pdim) - 1;
252 rank = GFC_DESCRIPTOR_RANK (array) - 1;
255 if (unlikely (dim < 0 || dim > rank))
257 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
258 "is %ld, should be between 1 and %ld",
259 (long int) dim + 1, (long int) rank + 1);
262 len = GFC_DESCRIPTOR_EXTENT(array,dim);
263 if (len <= 0)
264 return;
266 mbase = mask->base_addr;
268 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
270 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
271 #ifdef HAVE_GFC_LOGICAL_16
272 || mask_kind == 16
273 #endif
275 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
276 else
277 runtime_error ("Funny sized logical array");
279 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
280 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
282 for (n = 0; n < dim; n++)
284 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
285 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
286 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
288 if (extent[n] < 0)
289 extent[n] = 0;
292 for (n = dim; n < rank; n++)
294 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
295 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
296 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
298 if (extent[n] < 0)
299 extent[n] = 0;
302 if (retarray->base_addr == NULL)
304 size_t alloc_size, str;
306 for (n = 0; n < rank; n++)
308 if (n == 0)
309 str = 1;
310 else
311 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
313 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
317 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
319 retarray->offset = 0;
320 retarray->dtype.rank = rank;
322 if (alloc_size == 0)
324 /* Make sure we have a zero-sized array. */
325 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
326 return;
328 else
329 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
332 else
334 if (rank != GFC_DESCRIPTOR_RANK (retarray))
335 runtime_error ("rank of return array incorrect in MAXLOC intrinsic");
337 if (unlikely (compile_options.bounds_check))
339 bounds_ifunction_return ((array_t *) retarray, extent,
340 "return value", "MAXLOC");
341 bounds_equal_extents ((array_t *) mask, (array_t *) array,
342 "MASK argument", "MAXLOC");
346 for (n = 0; n < rank; n++)
348 count[n] = 0;
349 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
350 if (extent[n] <= 0)
351 return;
354 dest = retarray->base_addr;
355 base = array->base_addr;
357 while (base)
359 const GFC_INTEGER_8 * restrict src;
360 const GFC_LOGICAL_1 * restrict msrc;
361 GFC_INTEGER_8 result;
362 src = base;
363 msrc = mbase;
366 GFC_INTEGER_8 maxval;
367 #if defined (GFC_INTEGER_8_INFINITY)
368 maxval = -GFC_INTEGER_8_INFINITY;
369 #else
370 maxval = (-GFC_INTEGER_8_HUGE-1);
371 #endif
372 #if defined (GFC_INTEGER_8_QUIET_NAN)
373 GFC_INTEGER_8 result2 = 0;
374 #endif
375 result = 0;
376 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
379 if (*msrc)
381 #if defined (GFC_INTEGER_8_QUIET_NAN)
382 if (!result2)
383 result2 = (GFC_INTEGER_8)n + 1;
384 if (*src >= maxval)
385 #endif
387 maxval = *src;
388 result = (GFC_INTEGER_8)n + 1;
389 break;
393 #if defined (GFC_INTEGER_8_QUIET_NAN)
394 if (unlikely (n >= len))
395 result = result2;
396 else
397 #endif
398 if (back)
399 for (; n < len; n++, src += delta, msrc += mdelta)
401 if (*msrc && unlikely (*src >= maxval))
403 maxval = *src;
404 result = (GFC_INTEGER_8)n + 1;
407 else
408 for (; n < len; n++, src += delta, msrc += mdelta)
410 if (*msrc && unlikely (*src > maxval))
412 maxval = *src;
413 result = (GFC_INTEGER_8)n + 1;
416 *dest = result;
418 /* Advance to the next element. */
419 count[0]++;
420 base += sstride[0];
421 mbase += mstride[0];
422 dest += dstride[0];
423 n = 0;
424 while (count[n] == extent[n])
426 /* When we get to the end of a dimension, reset it and increment
427 the next dimension. */
428 count[n] = 0;
429 /* We could precalculate these products, but this is a less
430 frequently used path so probably not worth it. */
431 base -= sstride[n] * extent[n];
432 mbase -= mstride[n] * extent[n];
433 dest -= dstride[n] * extent[n];
434 n++;
435 if (n >= rank)
437 /* Break out of the loop. */
438 base = NULL;
439 break;
441 else
443 count[n]++;
444 base += sstride[n];
445 mbase += mstride[n];
446 dest += dstride[n];
453 extern void smaxloc1_8_i8 (gfc_array_i8 * const restrict,
454 gfc_array_i8 * const restrict, const index_type * const restrict,
455 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
456 export_proto(smaxloc1_8_i8);
458 void
459 smaxloc1_8_i8 (gfc_array_i8 * const restrict retarray,
460 gfc_array_i8 * const restrict array,
461 const index_type * const restrict pdim,
462 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
464 index_type count[GFC_MAX_DIMENSIONS];
465 index_type extent[GFC_MAX_DIMENSIONS];
466 index_type dstride[GFC_MAX_DIMENSIONS];
467 GFC_INTEGER_8 * restrict dest;
468 index_type rank;
469 index_type n;
470 index_type dim;
473 if (*mask)
475 #ifdef HAVE_BACK_ARG
476 maxloc1_8_i8 (retarray, array, pdim, back);
477 #else
478 maxloc1_8_i8 (retarray, array, pdim);
479 #endif
480 return;
482 /* Make dim zero based to avoid confusion. */
483 dim = (*pdim) - 1;
484 rank = GFC_DESCRIPTOR_RANK (array) - 1;
486 if (unlikely (dim < 0 || dim > rank))
488 runtime_error ("Dim argument incorrect in MAXLOC intrinsic: "
489 "is %ld, should be between 1 and %ld",
490 (long int) dim + 1, (long int) rank + 1);
493 for (n = 0; n < dim; n++)
495 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
497 if (extent[n] <= 0)
498 extent[n] = 0;
501 for (n = dim; n < rank; n++)
503 extent[n] =
504 GFC_DESCRIPTOR_EXTENT(array,n + 1);
506 if (extent[n] <= 0)
507 extent[n] = 0;
510 if (retarray->base_addr == NULL)
512 size_t alloc_size, str;
514 for (n = 0; n < rank; n++)
516 if (n == 0)
517 str = 1;
518 else
519 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
521 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
525 retarray->offset = 0;
526 retarray->dtype.rank = rank;
528 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
530 if (alloc_size == 0)
532 /* Make sure we have a zero-sized array. */
533 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
534 return;
536 else
537 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_8));
539 else
541 if (rank != GFC_DESCRIPTOR_RANK (retarray))
542 runtime_error ("rank of return array incorrect in"
543 " MAXLOC intrinsic: is %ld, should be %ld",
544 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
545 (long int) rank);
547 if (unlikely (compile_options.bounds_check))
549 for (n=0; n < rank; n++)
551 index_type ret_extent;
553 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
554 if (extent[n] != ret_extent)
555 runtime_error ("Incorrect extent in return value of"
556 " MAXLOC intrinsic in dimension %ld:"
557 " is %ld, should be %ld", (long int) n + 1,
558 (long int) ret_extent, (long int) extent[n]);
563 for (n = 0; n < rank; n++)
565 count[n] = 0;
566 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
569 dest = retarray->base_addr;
571 while(1)
573 *dest = 0;
574 count[0]++;
575 dest += dstride[0];
576 n = 0;
577 while (count[n] == extent[n])
579 /* When we get to the end of a dimension, reset it and increment
580 the next dimension. */
581 count[n] = 0;
582 /* We could precalculate these products, but this is a less
583 frequently used path so probably not worth it. */
584 dest -= dstride[n] * extent[n];
585 n++;
586 if (n >= rank)
587 return;
588 else
590 count[n]++;
591 dest += dstride[n];
597 #endif