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_REAL_10) && defined (HAVE_GFC_INTEGER_4)
41 extern void minloc0_4_r10 (gfc_array_i4 * const restrict retarray,
42 gfc_array_r10 * const restrict array);
43 export_proto(minloc0_4_r10);
46 minloc0_4_r10 (gfc_array_i4 * const restrict retarray,
47 gfc_array_r10 * const restrict array)
49 index_type count[GFC_MAX_DIMENSIONS];
50 index_type extent[GFC_MAX_DIMENSIONS];
51 index_type sstride[GFC_MAX_DIMENSIONS];
53 const GFC_REAL_10 *base;
58 rank = GFC_DESCRIPTOR_RANK (array);
60 runtime_error ("Rank of array needs to be > 0");
62 if (retarray->data == NULL)
64 retarray->dim[0].lbound = 0;
65 retarray->dim[0].ubound = rank-1;
66 retarray->dim[0].stride = 1;
67 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
69 retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
73 if (GFC_DESCRIPTOR_RANK (retarray) != 1)
74 runtime_error ("rank of return array does not equal 1");
76 if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
77 runtime_error ("dimension of return array incorrect");
80 dstride = retarray->dim[0].stride;
81 dest = retarray->data;
82 for (n = 0; n < rank; n++)
84 sstride[n] = array->dim[n].stride;
85 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
89 /* Set the return value. */
90 for (n = 0; n < rank; n++)
91 dest[n * dstride] = 0;
98 /* Initialize the return value. */
99 for (n = 0; n < rank; n++)
100 dest[n * dstride] = 0;
105 minval = GFC_REAL_10_HUGE;
110 /* Implementation start. */
112 if (*base < minval || !dest[0])
115 for (n = 0; n < rank; n++)
116 dest[n * dstride] = count[n] + 1;
118 /* Implementation end. */
120 /* Advance to the next element. */
124 while (count[n] == extent[n])
126 /* When we get to the end of a dimension, reset it and increment
127 the next dimension. */
129 /* We could precalculate these products, but this is a less
130 frequently used path so probably not worth it. */
131 base -= sstride[n] * extent[n];
135 /* Break out of the loop. */
150 extern void mminloc0_4_r10 (gfc_array_i4 * const restrict,
151 gfc_array_r10 * const restrict, gfc_array_l1 * const restrict);
152 export_proto(mminloc0_4_r10);
155 mminloc0_4_r10 (gfc_array_i4 * const restrict retarray,
156 gfc_array_r10 * const restrict array,
157 gfc_array_l1 * const restrict mask)
159 index_type count[GFC_MAX_DIMENSIONS];
160 index_type extent[GFC_MAX_DIMENSIONS];
161 index_type sstride[GFC_MAX_DIMENSIONS];
162 index_type mstride[GFC_MAX_DIMENSIONS];
165 const GFC_REAL_10 *base;
166 GFC_LOGICAL_1 *mbase;
171 rank = GFC_DESCRIPTOR_RANK (array);
173 runtime_error ("Rank of array needs to be > 0");
175 if (retarray->data == NULL)
177 retarray->dim[0].lbound = 0;
178 retarray->dim[0].ubound = rank-1;
179 retarray->dim[0].stride = 1;
180 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
181 retarray->offset = 0;
182 retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
186 if (GFC_DESCRIPTOR_RANK (retarray) != 1)
187 runtime_error ("rank of return array does not equal 1");
189 if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
190 runtime_error ("dimension of return array incorrect");
193 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
197 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
198 #ifdef HAVE_GFC_LOGICAL_16
202 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
204 runtime_error ("Funny sized logical array");
206 dstride = retarray->dim[0].stride;
207 dest = retarray->data;
208 for (n = 0; n < rank; n++)
210 sstride[n] = array->dim[n].stride;
211 mstride[n] = mask->dim[n].stride * mask_kind;
212 extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
216 /* Set the return value. */
217 for (n = 0; n < rank; n++)
218 dest[n * dstride] = 0;
225 /* Initialize the return value. */
226 for (n = 0; n < rank; n++)
227 dest[n * dstride] = 0;
232 minval = GFC_REAL_10_HUGE;
237 /* Implementation start. */
239 if (*mbase && (*base < minval || !dest[0]))
242 for (n = 0; n < rank; n++)
243 dest[n * dstride] = count[n] + 1;
245 /* Implementation end. */
247 /* Advance to the next element. */
252 while (count[n] == extent[n])
254 /* When we get to the end of a dimension, reset it and increment
255 the next dimension. */
257 /* We could precalculate these products, but this is a less
258 frequently used path so probably not worth it. */
259 base -= sstride[n] * extent[n];
260 mbase -= mstride[n] * extent[n];
264 /* Break out of the loop. */
280 extern void sminloc0_4_r10 (gfc_array_i4 * const restrict,
281 gfc_array_r10 * const restrict, GFC_LOGICAL_4 *);
282 export_proto(sminloc0_4_r10);
285 sminloc0_4_r10 (gfc_array_i4 * const restrict retarray,
286 gfc_array_r10 * const restrict array,
287 GFC_LOGICAL_4 * mask)
296 minloc0_4_r10 (retarray, array);
300 rank = GFC_DESCRIPTOR_RANK (array);
303 runtime_error ("Rank of array needs to be > 0");
305 if (retarray->data == NULL)
307 retarray->dim[0].lbound = 0;
308 retarray->dim[0].ubound = rank-1;
309 retarray->dim[0].stride = 1;
310 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
311 retarray->offset = 0;
312 retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
316 if (GFC_DESCRIPTOR_RANK (retarray) != 1)
317 runtime_error ("rank of return array does not equal 1");
319 if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
320 runtime_error ("dimension of return array incorrect");
323 dstride = retarray->dim[0].stride;
324 dest = retarray->data;
325 for (n = 0; n<rank; n++)
326 dest[n * dstride] = 0 ;