missing Changelog
[official-gcc.git] / libgfortran / generated / minval_r8.c
blob5a93248eafce36de64b241a17c6ae82a75bc3451
1 /* Implementation of the MINVAL intrinsic
2 Copyright 2002, 2007, 2009, 2010 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 <stdlib.h>
28 #include <assert.h>
31 #if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_REAL_8)
34 extern void minval_r8 (gfc_array_r8 * const restrict,
35 gfc_array_r8 * const restrict, const index_type * const restrict);
36 export_proto(minval_r8);
38 void
39 minval_r8 (gfc_array_r8 * const restrict retarray,
40 gfc_array_r8 * const restrict array,
41 const index_type * const restrict pdim)
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[GFC_MAX_DIMENSIONS];
47 const GFC_REAL_8 * restrict base;
48 GFC_REAL_8 * restrict dest;
49 index_type rank;
50 index_type n;
51 index_type len;
52 index_type delta;
53 index_type dim;
54 int continue_loop;
56 /* Make dim zero based to avoid confusion. */
57 dim = (*pdim) - 1;
58 rank = GFC_DESCRIPTOR_RANK (array) - 1;
60 len = GFC_DESCRIPTOR_EXTENT(array,dim);
61 if (len < 0)
62 len = 0;
63 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
65 for (n = 0; n < dim; n++)
67 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
68 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
70 if (extent[n] < 0)
71 extent[n] = 0;
73 for (n = dim; n < rank; n++)
75 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
76 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
78 if (extent[n] < 0)
79 extent[n] = 0;
82 if (retarray->base_addr == NULL)
84 size_t alloc_size, str;
86 for (n = 0; n < rank; n++)
88 if (n == 0)
89 str = 1;
90 else
91 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
93 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
97 retarray->offset = 0;
98 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
100 alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
101 * extent[rank-1];
103 retarray->base_addr = xmalloc (alloc_size);
104 if (alloc_size == 0)
106 /* Make sure we have a zero-sized array. */
107 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
108 return;
112 else
114 if (rank != GFC_DESCRIPTOR_RANK (retarray))
115 runtime_error ("rank of return array incorrect in"
116 " MINVAL intrinsic: is %ld, should be %ld",
117 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
118 (long int) rank);
120 if (unlikely (compile_options.bounds_check))
121 bounds_ifunction_return ((array_t *) retarray, extent,
122 "return value", "MINVAL");
125 for (n = 0; n < rank; n++)
127 count[n] = 0;
128 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
129 if (extent[n] <= 0)
130 return;
133 base = array->base_addr;
134 dest = retarray->base_addr;
136 continue_loop = 1;
137 while (continue_loop)
139 const GFC_REAL_8 * restrict src;
140 GFC_REAL_8 result;
141 src = base;
144 #if defined (GFC_REAL_8_INFINITY)
145 result = GFC_REAL_8_INFINITY;
146 #else
147 result = GFC_REAL_8_HUGE;
148 #endif
149 if (len <= 0)
150 *dest = GFC_REAL_8_HUGE;
151 else
153 for (n = 0; n < len; n++, src += delta)
156 #if defined (GFC_REAL_8_QUIET_NAN)
157 if (*src <= result)
158 break;
160 if (unlikely (n >= len))
161 result = GFC_REAL_8_QUIET_NAN;
162 else for (; n < len; n++, src += delta)
164 #endif
165 if (*src < result)
166 result = *src;
169 *dest = result;
172 /* Advance to the next element. */
173 count[0]++;
174 base += sstride[0];
175 dest += dstride[0];
176 n = 0;
177 while (count[n] == extent[n])
179 /* When we get to the end of a dimension, reset it and increment
180 the next dimension. */
181 count[n] = 0;
182 /* We could precalculate these products, but this is a less
183 frequently used path so probably not worth it. */
184 base -= sstride[n] * extent[n];
185 dest -= dstride[n] * extent[n];
186 n++;
187 if (n == rank)
189 /* Break out of the look. */
190 continue_loop = 0;
191 break;
193 else
195 count[n]++;
196 base += sstride[n];
197 dest += dstride[n];
204 extern void mminval_r8 (gfc_array_r8 * const restrict,
205 gfc_array_r8 * const restrict, const index_type * const restrict,
206 gfc_array_l1 * const restrict);
207 export_proto(mminval_r8);
209 void
210 mminval_r8 (gfc_array_r8 * const restrict retarray,
211 gfc_array_r8 * const restrict array,
212 const index_type * const restrict pdim,
213 gfc_array_l1 * const restrict mask)
215 index_type count[GFC_MAX_DIMENSIONS];
216 index_type extent[GFC_MAX_DIMENSIONS];
217 index_type sstride[GFC_MAX_DIMENSIONS];
218 index_type dstride[GFC_MAX_DIMENSIONS];
219 index_type mstride[GFC_MAX_DIMENSIONS];
220 GFC_REAL_8 * restrict dest;
221 const GFC_REAL_8 * restrict base;
222 const GFC_LOGICAL_1 * restrict mbase;
223 int rank;
224 int dim;
225 index_type n;
226 index_type len;
227 index_type delta;
228 index_type mdelta;
229 int mask_kind;
231 dim = (*pdim) - 1;
232 rank = GFC_DESCRIPTOR_RANK (array) - 1;
234 len = GFC_DESCRIPTOR_EXTENT(array,dim);
235 if (len <= 0)
236 return;
238 mbase = mask->base_addr;
240 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
242 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
243 #ifdef HAVE_GFC_LOGICAL_16
244 || mask_kind == 16
245 #endif
247 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
248 else
249 runtime_error ("Funny sized logical array");
251 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
252 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
254 for (n = 0; n < dim; n++)
256 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
257 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
258 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
260 if (extent[n] < 0)
261 extent[n] = 0;
264 for (n = dim; n < rank; n++)
266 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1);
267 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
268 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
270 if (extent[n] < 0)
271 extent[n] = 0;
274 if (retarray->base_addr == NULL)
276 size_t alloc_size, str;
278 for (n = 0; n < rank; n++)
280 if (n == 0)
281 str = 1;
282 else
283 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
285 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
289 alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
290 * extent[rank-1];
292 retarray->offset = 0;
293 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
295 if (alloc_size == 0)
297 /* Make sure we have a zero-sized array. */
298 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
299 return;
301 else
302 retarray->base_addr = xmalloc (alloc_size);
305 else
307 if (rank != GFC_DESCRIPTOR_RANK (retarray))
308 runtime_error ("rank of return array incorrect in MINVAL intrinsic");
310 if (unlikely (compile_options.bounds_check))
312 bounds_ifunction_return ((array_t *) retarray, extent,
313 "return value", "MINVAL");
314 bounds_equal_extents ((array_t *) mask, (array_t *) array,
315 "MASK argument", "MINVAL");
319 for (n = 0; n < rank; n++)
321 count[n] = 0;
322 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
323 if (extent[n] <= 0)
324 return;
327 dest = retarray->base_addr;
328 base = array->base_addr;
330 while (base)
332 const GFC_REAL_8 * restrict src;
333 const GFC_LOGICAL_1 * restrict msrc;
334 GFC_REAL_8 result;
335 src = base;
336 msrc = mbase;
339 #if defined (GFC_REAL_8_INFINITY)
340 result = GFC_REAL_8_INFINITY;
341 #else
342 result = GFC_REAL_8_HUGE;
343 #endif
344 #if defined (GFC_REAL_8_QUIET_NAN)
345 int non_empty_p = 0;
346 #endif
347 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
350 #if defined (GFC_REAL_8_INFINITY) || defined (GFC_REAL_8_QUIET_NAN)
351 if (*msrc)
353 #if defined (GFC_REAL_8_QUIET_NAN)
354 non_empty_p = 1;
355 if (*src <= result)
356 #endif
357 break;
360 if (unlikely (n >= len))
362 #if defined (GFC_REAL_8_QUIET_NAN)
363 result = non_empty_p ? GFC_REAL_8_QUIET_NAN : GFC_REAL_8_HUGE;
364 #else
365 result = GFC_REAL_8_HUGE;
366 #endif
368 else for (; n < len; n++, src += delta, msrc += mdelta)
370 #endif
371 if (*msrc && *src < result)
372 result = *src;
374 *dest = result;
376 /* Advance to the next element. */
377 count[0]++;
378 base += sstride[0];
379 mbase += mstride[0];
380 dest += dstride[0];
381 n = 0;
382 while (count[n] == extent[n])
384 /* When we get to the end of a dimension, reset it and increment
385 the next dimension. */
386 count[n] = 0;
387 /* We could precalculate these products, but this is a less
388 frequently used path so probably not worth it. */
389 base -= sstride[n] * extent[n];
390 mbase -= mstride[n] * extent[n];
391 dest -= dstride[n] * extent[n];
392 n++;
393 if (n == rank)
395 /* Break out of the look. */
396 base = NULL;
397 break;
399 else
401 count[n]++;
402 base += sstride[n];
403 mbase += mstride[n];
404 dest += dstride[n];
411 extern void sminval_r8 (gfc_array_r8 * const restrict,
412 gfc_array_r8 * const restrict, const index_type * const restrict,
413 GFC_LOGICAL_4 *);
414 export_proto(sminval_r8);
416 void
417 sminval_r8 (gfc_array_r8 * const restrict retarray,
418 gfc_array_r8 * const restrict array,
419 const index_type * const restrict pdim,
420 GFC_LOGICAL_4 * mask)
422 index_type count[GFC_MAX_DIMENSIONS];
423 index_type extent[GFC_MAX_DIMENSIONS];
424 index_type dstride[GFC_MAX_DIMENSIONS];
425 GFC_REAL_8 * restrict dest;
426 index_type rank;
427 index_type n;
428 index_type dim;
431 if (*mask)
433 minval_r8 (retarray, array, pdim);
434 return;
436 /* Make dim zero based to avoid confusion. */
437 dim = (*pdim) - 1;
438 rank = GFC_DESCRIPTOR_RANK (array) - 1;
440 for (n = 0; n < dim; n++)
442 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
444 if (extent[n] <= 0)
445 extent[n] = 0;
448 for (n = dim; n < rank; n++)
450 extent[n] =
451 GFC_DESCRIPTOR_EXTENT(array,n + 1);
453 if (extent[n] <= 0)
454 extent[n] = 0;
457 if (retarray->base_addr == NULL)
459 size_t alloc_size, str;
461 for (n = 0; n < rank; n++)
463 if (n == 0)
464 str = 1;
465 else
466 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
468 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
472 retarray->offset = 0;
473 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
475 alloc_size = sizeof (GFC_REAL_8) * GFC_DESCRIPTOR_STRIDE(retarray,rank-1)
476 * extent[rank-1];
478 if (alloc_size == 0)
480 /* Make sure we have a zero-sized array. */
481 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
482 return;
484 else
485 retarray->base_addr = xmalloc (alloc_size);
487 else
489 if (rank != GFC_DESCRIPTOR_RANK (retarray))
490 runtime_error ("rank of return array incorrect in"
491 " MINVAL intrinsic: is %ld, should be %ld",
492 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
493 (long int) rank);
495 if (unlikely (compile_options.bounds_check))
497 for (n=0; n < rank; n++)
499 index_type ret_extent;
501 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
502 if (extent[n] != ret_extent)
503 runtime_error ("Incorrect extent in return value of"
504 " MINVAL intrinsic in dimension %ld:"
505 " is %ld, should be %ld", (long int) n + 1,
506 (long int) ret_extent, (long int) extent[n]);
511 for (n = 0; n < rank; n++)
513 count[n] = 0;
514 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
517 dest = retarray->base_addr;
519 while(1)
521 *dest = GFC_REAL_8_HUGE;
522 count[0]++;
523 dest += dstride[0];
524 n = 0;
525 while (count[n] == extent[n])
527 /* When we get to the end of a dimension, reset it and increment
528 the next dimension. */
529 count[n] = 0;
530 /* We could precalculate these products, but this is a less
531 frequently used path so probably not worth it. */
532 dest -= dstride[n] * extent[n];
533 n++;
534 if (n == rank)
535 return;
536 else
538 count[n]++;
539 dest += dstride[n];
545 #endif