2018-03-09 François Dumont <fdumont@gcc.gnu.org>
[official-gcc.git] / libgfortran / generated / minloc1_16_i16.c
blobfc718a894c6d43ecd037764e9ad0c46860320ee7
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_16) && defined (HAVE_GFC_INTEGER_16)
32 #define HAVE_BACK_ARG 1
35 extern void minloc1_16_i16 (gfc_array_i16 * const restrict,
36 gfc_array_i16 * const restrict, const index_type * const restrict, GFC_LOGICAL_4 back);
37 export_proto(minloc1_16_i16);
39 void
40 minloc1_16_i16 (gfc_array_i16 * const restrict retarray,
41 gfc_array_i16 * 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_16 * restrict base;
49 GFC_INTEGER_16 * 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 #ifdef HAVE_BACK_ARG
58 assert(back == 0);
59 #endif
61 /* Make dim zero based to avoid confusion. */
62 rank = GFC_DESCRIPTOR_RANK (array) - 1;
63 dim = (*pdim) - 1;
65 if (unlikely (dim < 0 || dim > rank))
67 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
68 "is %ld, should be between 1 and %ld",
69 (long int) dim + 1, (long int) rank + 1);
72 len = GFC_DESCRIPTOR_EXTENT(array,dim);
73 if (len < 0)
74 len = 0;
75 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
77 for (n = 0; n < dim; n++)
79 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
82 if (extent[n] < 0)
83 extent[n] = 0;
85 for (n = dim; n < rank; n++)
87 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
88 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
90 if (extent[n] < 0)
91 extent[n] = 0;
94 if (retarray->base_addr == NULL)
96 size_t alloc_size, str;
98 for (n = 0; n < rank; n++)
100 if (n == 0)
101 str = 1;
102 else
103 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
105 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
109 retarray->offset = 0;
110 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
112 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
114 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
115 if (alloc_size == 0)
117 /* Make sure we have a zero-sized array. */
118 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
119 return;
123 else
125 if (rank != GFC_DESCRIPTOR_RANK (retarray))
126 runtime_error ("rank of return array incorrect in"
127 " MINLOC intrinsic: is %ld, should be %ld",
128 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
129 (long int) rank);
131 if (unlikely (compile_options.bounds_check))
132 bounds_ifunction_return ((array_t *) retarray, extent,
133 "return value", "MINLOC");
136 for (n = 0; n < rank; n++)
138 count[n] = 0;
139 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
140 if (extent[n] <= 0)
141 return;
144 base = array->base_addr;
145 dest = retarray->base_addr;
147 continue_loop = 1;
148 while (continue_loop)
150 const GFC_INTEGER_16 * restrict src;
151 GFC_INTEGER_16 result;
152 src = base;
155 GFC_INTEGER_16 minval;
156 #if defined (GFC_INTEGER_16_INFINITY)
157 minval = GFC_INTEGER_16_INFINITY;
158 #else
159 minval = GFC_INTEGER_16_HUGE;
160 #endif
161 result = 1;
162 if (len <= 0)
163 *dest = 0;
164 else
166 for (n = 0; n < len; n++, src += delta)
169 #if defined (GFC_INTEGER_16_QUIET_NAN)
170 if (*src <= minval)
172 minval = *src;
173 result = (GFC_INTEGER_16)n + 1;
174 break;
177 for (; n < len; n++, src += delta)
179 #endif
180 if (*src < minval)
182 minval = *src;
183 result = (GFC_INTEGER_16)n + 1;
187 *dest = result;
190 /* Advance to the next element. */
191 count[0]++;
192 base += sstride[0];
193 dest += dstride[0];
194 n = 0;
195 while (count[n] == extent[n])
197 /* When we get to the end of a dimension, reset it and increment
198 the next dimension. */
199 count[n] = 0;
200 /* We could precalculate these products, but this is a less
201 frequently used path so probably not worth it. */
202 base -= sstride[n] * extent[n];
203 dest -= dstride[n] * extent[n];
204 n++;
205 if (n >= rank)
207 /* Break out of the loop. */
208 continue_loop = 0;
209 break;
211 else
213 count[n]++;
214 base += sstride[n];
215 dest += dstride[n];
222 extern void mminloc1_16_i16 (gfc_array_i16 * const restrict,
223 gfc_array_i16 * const restrict, const index_type * const restrict,
224 gfc_array_l1 * const restrict, GFC_LOGICAL_4 back);
225 export_proto(mminloc1_16_i16);
227 void
228 mminloc1_16_i16 (gfc_array_i16 * const restrict retarray,
229 gfc_array_i16 * const restrict array,
230 const index_type * const restrict pdim,
231 gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back)
233 index_type count[GFC_MAX_DIMENSIONS];
234 index_type extent[GFC_MAX_DIMENSIONS];
235 index_type sstride[GFC_MAX_DIMENSIONS];
236 index_type dstride[GFC_MAX_DIMENSIONS];
237 index_type mstride[GFC_MAX_DIMENSIONS];
238 GFC_INTEGER_16 * restrict dest;
239 const GFC_INTEGER_16 * restrict base;
240 const GFC_LOGICAL_1 * restrict mbase;
241 index_type rank;
242 index_type dim;
243 index_type n;
244 index_type len;
245 index_type delta;
246 index_type mdelta;
247 int mask_kind;
249 #ifdef HAVE_BACK_ARG
250 assert (back == 0);
251 #endif
252 dim = (*pdim) - 1;
253 rank = GFC_DESCRIPTOR_RANK (array) - 1;
256 if (unlikely (dim < 0 || dim > rank))
258 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
259 "is %ld, should be between 1 and %ld",
260 (long int) dim + 1, (long int) rank + 1);
263 len = GFC_DESCRIPTOR_EXTENT(array,dim);
264 if (len <= 0)
265 return;
267 mbase = mask->base_addr;
269 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
271 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
272 #ifdef HAVE_GFC_LOGICAL_16
273 || mask_kind == 16
274 #endif
276 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
277 else
278 runtime_error ("Funny sized logical array");
280 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
281 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
283 for (n = 0; n < dim; n++)
285 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
286 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
287 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
289 if (extent[n] < 0)
290 extent[n] = 0;
293 for (n = dim; n < rank; n++)
295 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
296 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
297 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
299 if (extent[n] < 0)
300 extent[n] = 0;
303 if (retarray->base_addr == NULL)
305 size_t alloc_size, str;
307 for (n = 0; n < rank; n++)
309 if (n == 0)
310 str = 1;
311 else
312 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
314 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
318 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
320 retarray->offset = 0;
321 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
323 if (alloc_size == 0)
325 /* Make sure we have a zero-sized array. */
326 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
327 return;
329 else
330 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
333 else
335 if (rank != GFC_DESCRIPTOR_RANK (retarray))
336 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
338 if (unlikely (compile_options.bounds_check))
340 bounds_ifunction_return ((array_t *) retarray, extent,
341 "return value", "MINLOC");
342 bounds_equal_extents ((array_t *) mask, (array_t *) array,
343 "MASK argument", "MINLOC");
347 for (n = 0; n < rank; n++)
349 count[n] = 0;
350 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
351 if (extent[n] <= 0)
352 return;
355 dest = retarray->base_addr;
356 base = array->base_addr;
358 while (base)
360 const GFC_INTEGER_16 * restrict src;
361 const GFC_LOGICAL_1 * restrict msrc;
362 GFC_INTEGER_16 result;
363 src = base;
364 msrc = mbase;
367 GFC_INTEGER_16 minval;
368 #if defined (GFC_INTEGER_16_INFINITY)
369 minval = GFC_INTEGER_16_INFINITY;
370 #else
371 minval = GFC_INTEGER_16_HUGE;
372 #endif
373 #if defined (GFC_INTEGER_16_QUIET_NAN)
374 GFC_INTEGER_16 result2 = 0;
375 #endif
376 result = 0;
377 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
380 if (*msrc)
382 #if defined (GFC_INTEGER_16_QUIET_NAN)
383 if (!result2)
384 result2 = (GFC_INTEGER_16)n + 1;
385 if (*src <= minval)
386 #endif
388 minval = *src;
389 result = (GFC_INTEGER_16)n + 1;
390 break;
394 #if defined (GFC_INTEGER_16_QUIET_NAN)
395 if (unlikely (n >= len))
396 result = result2;
397 else
398 #endif
399 for (; n < len; n++, src += delta, msrc += mdelta)
401 if (*msrc && *src < minval)
403 minval = *src;
404 result = (GFC_INTEGER_16)n + 1;
407 *dest = result;
409 /* Advance to the next element. */
410 count[0]++;
411 base += sstride[0];
412 mbase += mstride[0];
413 dest += dstride[0];
414 n = 0;
415 while (count[n] == extent[n])
417 /* When we get to the end of a dimension, reset it and increment
418 the next dimension. */
419 count[n] = 0;
420 /* We could precalculate these products, but this is a less
421 frequently used path so probably not worth it. */
422 base -= sstride[n] * extent[n];
423 mbase -= mstride[n] * extent[n];
424 dest -= dstride[n] * extent[n];
425 n++;
426 if (n >= rank)
428 /* Break out of the loop. */
429 base = NULL;
430 break;
432 else
434 count[n]++;
435 base += sstride[n];
436 mbase += mstride[n];
437 dest += dstride[n];
444 extern void sminloc1_16_i16 (gfc_array_i16 * const restrict,
445 gfc_array_i16 * const restrict, const index_type * const restrict,
446 GFC_LOGICAL_4 *, GFC_LOGICAL_4 back);
447 export_proto(sminloc1_16_i16);
449 void
450 sminloc1_16_i16 (gfc_array_i16 * const restrict retarray,
451 gfc_array_i16 * const restrict array,
452 const index_type * const restrict pdim,
453 GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
455 index_type count[GFC_MAX_DIMENSIONS];
456 index_type extent[GFC_MAX_DIMENSIONS];
457 index_type dstride[GFC_MAX_DIMENSIONS];
458 GFC_INTEGER_16 * restrict dest;
459 index_type rank;
460 index_type n;
461 index_type dim;
464 if (*mask)
466 #ifdef HAVE_BACK_ARG
467 minloc1_16_i16 (retarray, array, pdim, back);
468 #else
469 minloc1_16_i16 (retarray, array, pdim);
470 #endif
471 return;
473 /* Make dim zero based to avoid confusion. */
474 dim = (*pdim) - 1;
475 rank = GFC_DESCRIPTOR_RANK (array) - 1;
477 if (unlikely (dim < 0 || dim > rank))
479 runtime_error ("Dim argument incorrect in MINLOC intrinsic: "
480 "is %ld, should be between 1 and %ld",
481 (long int) dim + 1, (long int) rank + 1);
484 for (n = 0; n < dim; n++)
486 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
488 if (extent[n] <= 0)
489 extent[n] = 0;
492 for (n = dim; n < rank; n++)
494 extent[n] =
495 GFC_DESCRIPTOR_EXTENT(array,n + 1);
497 if (extent[n] <= 0)
498 extent[n] = 0;
501 if (retarray->base_addr == NULL)
503 size_t alloc_size, str;
505 for (n = 0; n < rank; n++)
507 if (n == 0)
508 str = 1;
509 else
510 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
512 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
516 retarray->offset = 0;
517 GFC_DTYPE_COPY_SETRANK(retarray,array,rank);
519 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
521 if (alloc_size == 0)
523 /* Make sure we have a zero-sized array. */
524 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
525 return;
527 else
528 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_16));
530 else
532 if (rank != GFC_DESCRIPTOR_RANK (retarray))
533 runtime_error ("rank of return array incorrect in"
534 " MINLOC intrinsic: is %ld, should be %ld",
535 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
536 (long int) rank);
538 if (unlikely (compile_options.bounds_check))
540 for (n=0; n < rank; n++)
542 index_type ret_extent;
544 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
545 if (extent[n] != ret_extent)
546 runtime_error ("Incorrect extent in return value of"
547 " MINLOC intrinsic in dimension %ld:"
548 " is %ld, should be %ld", (long int) n + 1,
549 (long int) ret_extent, (long int) extent[n]);
554 for (n = 0; n < rank; n++)
556 count[n] = 0;
557 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
560 dest = retarray->base_addr;
562 while(1)
564 *dest = 0;
565 count[0]++;
566 dest += dstride[0];
567 n = 0;
568 while (count[n] == extent[n])
570 /* When we get to the end of a dimension, reset it and increment
571 the next dimension. */
572 count[n] = 0;
573 /* We could precalculate these products, but this is a less
574 frequently used path so probably not worth it. */
575 dest -= dstride[n] * extent[n];
576 n++;
577 if (n >= rank)
578 return;
579 else
581 count[n]++;
582 dest += dstride[n];
588 #endif