1 /* Implementation of the MINLOC intrinsic
2 Copyright 2002 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
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. */
35 #include "libgfortran.h"
38 #if defined (HAVE_GFC_INTEGER_1) && defined (HAVE_GFC_INTEGER_8)
41 extern void minloc1_8_i1 (gfc_array_i8 * const restrict,
42 gfc_array_i1 * const restrict, const index_type * const restrict);
43 export_proto(minloc1_8_i1);
46 minloc1_8_i1 (gfc_array_i8 * const restrict retarray,
47 gfc_array_i1 * const restrict array,
48 const index_type * const restrict pdim)
50 index_type count[GFC_MAX_DIMENSIONS];
51 index_type extent[GFC_MAX_DIMENSIONS];
52 index_type sstride[GFC_MAX_DIMENSIONS];
53 index_type dstride[GFC_MAX_DIMENSIONS];
54 const GFC_INTEGER_1 * restrict base;
55 GFC_INTEGER_8 * restrict dest;
62 /* Make dim zero based to avoid confusion. */
64 rank = GFC_DESCRIPTOR_RANK (array) - 1;
66 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
67 delta = array->dim[dim].stride;
69 for (n = 0; n < dim; n++)
71 sstride[n] = array->dim[n].stride;
72 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
77 for (n = dim; n < rank; n++)
79 sstride[n] = array->dim[n + 1].stride;
81 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
87 if (retarray->data == NULL)
91 for (n = 0; n < rank; n++)
93 retarray->dim[n].lbound = 0;
94 retarray->dim[n].ubound = extent[n]-1;
96 retarray->dim[n].stride = 1;
98 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
101 retarray->offset = 0;
102 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
104 alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
109 /* Make sure we have a zero-sized array. */
110 retarray->dim[0].lbound = 0;
111 retarray->dim[0].ubound = -1;
115 retarray->data = internal_malloc_size (alloc_size);
119 if (rank != GFC_DESCRIPTOR_RANK (retarray))
120 runtime_error ("rank of return array incorrect");
123 for (n = 0; n < rank; n++)
126 dstride[n] = retarray->dim[n].stride;
132 dest = retarray->data;
136 const GFC_INTEGER_1 * restrict src;
137 GFC_INTEGER_8 result;
141 GFC_INTEGER_1 minval;
142 minval = GFC_INTEGER_1_HUGE;
148 for (n = 0; n < len; n++, src += delta)
151 if (*src < minval || !result)
154 result = (GFC_INTEGER_8)n + 1;
160 /* Advance to the next element. */
165 while (count[n] == extent[n])
167 /* When we get to the end of a dimension, reset it and increment
168 the next dimension. */
170 /* We could precalculate these products, but this is a less
171 frequently used path so probably not worth it. */
172 base -= sstride[n] * extent[n];
173 dest -= dstride[n] * extent[n];
177 /* Break out of the look. */
192 extern void mminloc1_8_i1 (gfc_array_i8 * const restrict,
193 gfc_array_i1 * const restrict, const index_type * const restrict,
194 gfc_array_l1 * const restrict);
195 export_proto(mminloc1_8_i1);
198 mminloc1_8_i1 (gfc_array_i8 * const restrict retarray,
199 gfc_array_i1 * const restrict array,
200 const index_type * const restrict pdim,
201 gfc_array_l1 * const restrict mask)
203 index_type count[GFC_MAX_DIMENSIONS];
204 index_type extent[GFC_MAX_DIMENSIONS];
205 index_type sstride[GFC_MAX_DIMENSIONS];
206 index_type dstride[GFC_MAX_DIMENSIONS];
207 index_type mstride[GFC_MAX_DIMENSIONS];
208 GFC_INTEGER_8 * restrict dest;
209 const GFC_INTEGER_1 * restrict base;
210 const GFC_LOGICAL_1 * restrict mbase;
220 rank = GFC_DESCRIPTOR_RANK (array) - 1;
222 len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
228 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
230 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
231 #ifdef HAVE_GFC_LOGICAL_16
235 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
237 runtime_error ("Funny sized logical array");
239 delta = array->dim[dim].stride;
240 mdelta = mask->dim[dim].stride * mask_kind;
242 for (n = 0; n < dim; n++)
244 sstride[n] = array->dim[n].stride;
245 mstride[n] = mask->dim[n].stride * mask_kind;
246 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
252 for (n = dim; n < rank; n++)
254 sstride[n] = array->dim[n + 1].stride;
255 mstride[n] = mask->dim[n + 1].stride * mask_kind;
257 array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
263 if (retarray->data == NULL)
267 for (n = 0; n < rank; n++)
269 retarray->dim[n].lbound = 0;
270 retarray->dim[n].ubound = extent[n]-1;
272 retarray->dim[n].stride = 1;
274 retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
277 alloc_size = sizeof (GFC_INTEGER_8) * retarray->dim[rank-1].stride
280 retarray->offset = 0;
281 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
285 /* Make sure we have a zero-sized array. */
286 retarray->dim[0].lbound = 0;
287 retarray->dim[0].ubound = -1;
291 retarray->data = internal_malloc_size (alloc_size);
296 if (rank != GFC_DESCRIPTOR_RANK (retarray))
297 runtime_error ("rank of return array incorrect");
300 for (n = 0; n < rank; n++)
303 dstride[n] = retarray->dim[n].stride;
308 dest = retarray->data;
313 const GFC_INTEGER_1 * restrict src;
314 const GFC_LOGICAL_1 * restrict msrc;
315 GFC_INTEGER_8 result;
320 GFC_INTEGER_1 minval;
321 minval = GFC_INTEGER_1_HUGE;
327 for (n = 0; n < len; n++, src += delta, msrc += mdelta)
330 if (*msrc && (*src < minval || !result))
333 result = (GFC_INTEGER_8)n + 1;
339 /* Advance to the next element. */
345 while (count[n] == extent[n])
347 /* When we get to the end of a dimension, reset it and increment
348 the next dimension. */
350 /* We could precalculate these products, but this is a less
351 frequently used path so probably not worth it. */
352 base -= sstride[n] * extent[n];
353 mbase -= mstride[n] * extent[n];
354 dest -= dstride[n] * extent[n];
358 /* Break out of the look. */
374 extern void sminloc1_8_i1 (gfc_array_i8 * const restrict,
375 gfc_array_i1 * const restrict, const index_type * const restrict,
377 export_proto(sminloc1_8_i1);
380 sminloc1_8_i1 (gfc_array_i8 * const restrict retarray,
381 gfc_array_i1 * const restrict array,
382 const index_type * const restrict pdim,
383 GFC_LOGICAL_4 * mask)
392 minloc1_8_i1 (retarray, array, pdim);
395 rank = GFC_DESCRIPTOR_RANK (array);
397 runtime_error ("Rank of array needs to be > 0");
399 if (retarray->data == NULL)
401 retarray->dim[0].lbound = 0;
402 retarray->dim[0].ubound = rank-1;
403 retarray->dim[0].stride = 1;
404 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
405 retarray->offset = 0;
406 retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_8) * rank);
410 if (GFC_DESCRIPTOR_RANK (retarray) != 1)
411 runtime_error ("rank of return array does not equal 1");
413 if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
414 runtime_error ("dimension of return array incorrect");
417 dstride = retarray->dim[0].stride;
418 dest = retarray->data;
420 for (n = 0; n < rank; n++)
421 dest[n * dstride] = 0 ;