Daily bump.
[official-gcc.git] / libgfortran / generated / maxval_r10.c
blob3a423ff2008b377227500809c8a48ac091d8cc43
1 /* Implementation of the MAXVAL intrinsic
2 Copyright 2002, 2007 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 95 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 2 of the License, or (at your option) any later version.
12 In addition to the permissions in the GNU General Public License, the
13 Free Software Foundation gives you unlimited permission to link the
14 compiled version of this file into combinations with other programs,
15 and to distribute those combinations without any restriction coming
16 from the use of this file. (The General Public License restrictions
17 do apply in other respects; for example, they cover modification of
18 the file, and distribution when not linked into a combine
19 executable.)
21 Libgfortran is distributed in the hope that it will be useful,
22 but WITHOUT ANY WARRANTY; without even the implied warranty of
23 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 GNU General Public License for more details.
26 You should have received a copy of the GNU General Public
27 License along with libgfortran; see the file COPYING. If not,
28 write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
29 Boston, MA 02110-1301, USA. */
31 #include "libgfortran.h"
32 #include <stdlib.h>
33 #include <assert.h>
36 #if defined (HAVE_GFC_REAL_10) && defined (HAVE_GFC_REAL_10)
39 extern void maxval_r10 (gfc_array_r10 * const restrict,
40 gfc_array_r10 * const restrict, const index_type * const restrict);
41 export_proto(maxval_r10);
43 void
44 maxval_r10 (gfc_array_r10 * const restrict retarray,
45 gfc_array_r10 * const restrict array,
46 const index_type * const restrict pdim)
48 index_type count[GFC_MAX_DIMENSIONS];
49 index_type extent[GFC_MAX_DIMENSIONS];
50 index_type sstride[GFC_MAX_DIMENSIONS];
51 index_type dstride[GFC_MAX_DIMENSIONS];
52 const GFC_REAL_10 * restrict base;
53 GFC_REAL_10 * restrict dest;
54 index_type rank;
55 index_type n;
56 index_type len;
57 index_type delta;
58 index_type dim;
60 /* Make dim zero based to avoid confusion. */
61 dim = (*pdim) - 1;
62 rank = GFC_DESCRIPTOR_RANK (array) - 1;
64 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
65 delta = array->dim[dim].stride;
67 for (n = 0; n < dim; n++)
69 sstride[n] = array->dim[n].stride;
70 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
72 if (extent[n] < 0)
73 extent[n] = 0;
75 for (n = dim; n < rank; n++)
77 sstride[n] = array->dim[n + 1].stride;
78 extent[n] =
79 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
81 if (extent[n] < 0)
82 extent[n] = 0;
85 if (retarray->data == NULL)
87 size_t alloc_size;
89 for (n = 0; n < rank; n++)
91 retarray->dim[n].lbound = 0;
92 retarray->dim[n].ubound = extent[n]-1;
93 if (n == 0)
94 retarray->dim[n].stride = 1;
95 else
96 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
99 retarray->offset = 0;
100 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
102 alloc_size = sizeof (GFC_REAL_10) * retarray->dim[rank-1].stride
103 * extent[rank-1];
105 if (alloc_size == 0)
107 /* Make sure we have a zero-sized array. */
108 retarray->dim[0].lbound = 0;
109 retarray->dim[0].ubound = -1;
110 return;
112 else
113 retarray->data = internal_malloc_size (alloc_size);
115 else
117 if (rank != GFC_DESCRIPTOR_RANK (retarray))
118 runtime_error ("rank of return array incorrect");
121 for (n = 0; n < rank; n++)
123 count[n] = 0;
124 dstride[n] = retarray->dim[n].stride;
125 if (extent[n] <= 0)
126 len = 0;
129 base = array->data;
130 dest = retarray->data;
132 while (base)
134 const GFC_REAL_10 * restrict src;
135 GFC_REAL_10 result;
136 src = base;
139 result = -GFC_REAL_10_HUGE;
140 if (len <= 0)
141 *dest = -GFC_REAL_10_HUGE;
142 else
144 for (n = 0; n < len; n++, src += delta)
147 if (*src > result)
148 result = *src;
150 *dest = result;
153 /* Advance to the next element. */
154 count[0]++;
155 base += sstride[0];
156 dest += dstride[0];
157 n = 0;
158 while (count[n] == extent[n])
160 /* When we get to the end of a dimension, reset it and increment
161 the next dimension. */
162 count[n] = 0;
163 /* We could precalculate these products, but this is a less
164 frequently used path so probably not worth it. */
165 base -= sstride[n] * extent[n];
166 dest -= dstride[n] * extent[n];
167 n++;
168 if (n == rank)
170 /* Break out of the look. */
171 base = NULL;
172 break;
174 else
176 count[n]++;
177 base += sstride[n];
178 dest += dstride[n];
185 extern void mmaxval_r10 (gfc_array_r10 * const restrict,
186 gfc_array_r10 * const restrict, const index_type * const restrict,
187 gfc_array_l1 * const restrict);
188 export_proto(mmaxval_r10);
190 void
191 mmaxval_r10 (gfc_array_r10 * const restrict retarray,
192 gfc_array_r10 * const restrict array,
193 const index_type * const restrict pdim,
194 gfc_array_l1 * const restrict mask)
196 index_type count[GFC_MAX_DIMENSIONS];
197 index_type extent[GFC_MAX_DIMENSIONS];
198 index_type sstride[GFC_MAX_DIMENSIONS];
199 index_type dstride[GFC_MAX_DIMENSIONS];
200 index_type mstride[GFC_MAX_DIMENSIONS];
201 GFC_REAL_10 * restrict dest;
202 const GFC_REAL_10 * restrict base;
203 const GFC_LOGICAL_1 * restrict mbase;
204 int rank;
205 int dim;
206 index_type n;
207 index_type len;
208 index_type delta;
209 index_type mdelta;
210 int mask_kind;
212 dim = (*pdim) - 1;
213 rank = GFC_DESCRIPTOR_RANK (array) - 1;
215 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
216 if (len <= 0)
217 return;
219 mbase = mask->data;
221 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
223 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
224 #ifdef HAVE_GFC_LOGICAL_16
225 || mask_kind == 16
226 #endif
228 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
229 else
230 runtime_error ("Funny sized logical array");
232 delta = array->dim[dim].stride;
233 mdelta = mask->dim[dim].stride * mask_kind;
235 for (n = 0; n < dim; n++)
237 sstride[n] = array->dim[n].stride;
238 mstride[n] = mask->dim[n].stride * mask_kind;
239 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
241 if (extent[n] < 0)
242 extent[n] = 0;
245 for (n = dim; n < rank; n++)
247 sstride[n] = array->dim[n + 1].stride;
248 mstride[n] = mask->dim[n + 1].stride * mask_kind;
249 extent[n] =
250 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
252 if (extent[n] < 0)
253 extent[n] = 0;
256 if (retarray->data == NULL)
258 size_t alloc_size;
260 for (n = 0; n < rank; n++)
262 retarray->dim[n].lbound = 0;
263 retarray->dim[n].ubound = extent[n]-1;
264 if (n == 0)
265 retarray->dim[n].stride = 1;
266 else
267 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
270 alloc_size = sizeof (GFC_REAL_10) * retarray->dim[rank-1].stride
271 * extent[rank-1];
273 retarray->offset = 0;
274 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
276 if (alloc_size == 0)
278 /* Make sure we have a zero-sized array. */
279 retarray->dim[0].lbound = 0;
280 retarray->dim[0].ubound = -1;
281 return;
283 else
284 retarray->data = internal_malloc_size (alloc_size);
287 else
289 if (rank != GFC_DESCRIPTOR_RANK (retarray))
290 runtime_error ("rank of return array incorrect");
293 for (n = 0; n < rank; n++)
295 count[n] = 0;
296 dstride[n] = retarray->dim[n].stride;
297 if (extent[n] <= 0)
298 return;
301 dest = retarray->data;
302 base = array->data;
304 while (base)
306 const GFC_REAL_10 * restrict src;
307 const GFC_LOGICAL_1 * restrict msrc;
308 GFC_REAL_10 result;
309 src = base;
310 msrc = mbase;
313 result = -GFC_REAL_10_HUGE;
314 if (len <= 0)
315 *dest = -GFC_REAL_10_HUGE;
316 else
318 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
321 if (*msrc && *src > result)
322 result = *src;
324 *dest = result;
327 /* Advance to the next element. */
328 count[0]++;
329 base += sstride[0];
330 mbase += mstride[0];
331 dest += dstride[0];
332 n = 0;
333 while (count[n] == extent[n])
335 /* When we get to the end of a dimension, reset it and increment
336 the next dimension. */
337 count[n] = 0;
338 /* We could precalculate these products, but this is a less
339 frequently used path so probably not worth it. */
340 base -= sstride[n] * extent[n];
341 mbase -= mstride[n] * extent[n];
342 dest -= dstride[n] * extent[n];
343 n++;
344 if (n == rank)
346 /* Break out of the look. */
347 base = NULL;
348 break;
350 else
352 count[n]++;
353 base += sstride[n];
354 mbase += mstride[n];
355 dest += dstride[n];
362 extern void smaxval_r10 (gfc_array_r10 * const restrict,
363 gfc_array_r10 * const restrict, const index_type * const restrict,
364 GFC_LOGICAL_4 *);
365 export_proto(smaxval_r10);
367 void
368 smaxval_r10 (gfc_array_r10 * const restrict retarray,
369 gfc_array_r10 * const restrict array,
370 const index_type * const restrict pdim,
371 GFC_LOGICAL_4 * mask)
373 index_type rank;
374 index_type n;
375 index_type dstride;
376 GFC_REAL_10 *dest;
378 if (*mask)
380 maxval_r10 (retarray, array, pdim);
381 return;
383 rank = GFC_DESCRIPTOR_RANK (array);
384 if (rank <= 0)
385 runtime_error ("Rank of array needs to be > 0");
387 if (retarray->data == NULL)
389 retarray->dim[0].lbound = 0;
390 retarray->dim[0].ubound = rank-1;
391 retarray->dim[0].stride = 1;
392 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
393 retarray->offset = 0;
394 retarray->data = internal_malloc_size (sizeof (GFC_REAL_10) * rank);
396 else
398 if (GFC_DESCRIPTOR_RANK (retarray) != 1)
399 runtime_error ("rank of return array does not equal 1");
401 if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
402 runtime_error ("dimension of return array incorrect");
405 dstride = retarray->dim[0].stride;
406 dest = retarray->data;
408 for (n = 0; n < rank; n++)
409 dest[n * dstride] = -GFC_REAL_10_HUGE ;
412 #endif