OpenCores
URL https://opencores.org/ocsvn/scarts/scarts/trunk

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [libgfortran/] [generated/] [minloc0_4_r8.c] - Blame information for rev 14

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 14 jlechner 
/* Implementation of the MINLOC intrinsic
2 
   Copyright 2002 Free Software Foundation, Inc.
3 
   Contributed by Paul Brook <paul@nowt.org>
4 
 
5 
This file is part of the GNU Fortran 95 runtime library (libgfortran).
6 
 
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.
11 
 
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.)
20 
 
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.
25 
 
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.  */
30 
 
31 
#include "config.h"
32 
#include <stdlib.h>
33 
#include <assert.h>
34 
#include <float.h>
35 
#include <limits.h>
36 
#include "libgfortran.h"
37 
 
38 
 
39 
#if defined (HAVE_GFC_REAL_8) && defined (HAVE_GFC_INTEGER_4)
40 
 
41 
 
42 
extern void minloc0_4_r8 (gfc_array_i4 * retarray, gfc_array_r8 *array);
43 
export_proto(minloc0_4_r8);
44 
 
45 
void
46 
minloc0_4_r8 (gfc_array_i4 * retarray, gfc_array_r8 *array)
47 
{
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;
52 
  GFC_REAL_8 *base;
53 
  GFC_INTEGER_4 *dest;
54 
  index_type rank;
55 
  index_type n;
56 
 
57 
  rank = GFC_DESCRIPTOR_RANK (array);
58 
  if (rank <= 0)
59 
    runtime_error ("Rank of array needs to be > 0");
60 
 
61 
  if (retarray->data == NULL)
62 
    {
63 
      retarray->dim[0].lbound = 0;
64 
      retarray->dim[0].ubound = rank-1;
65 
      retarray->dim[0].stride = 1;
66 
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
67 
      retarray->offset = 0;
68 
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
69 
    }
70 
  else
71 
    {
72 
      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
73 
        runtime_error ("rank of return array does not equal 1");
74 
 
75 
      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
76 
        runtime_error ("dimension of return array incorrect");
77 
 
78 
      if (retarray->dim[0].stride == 0)
79 
        retarray->dim[0].stride = 1;
80 
    }
81 
 
82 
  /* TODO:  It should be a front end job to correctly set the strides.  */
83 
 
84 
  if (array->dim[0].stride == 0)
85 
    array->dim[0].stride = 1;
86 
 
87 
  dstride = retarray->dim[0].stride;
88 
  dest = retarray->data;
89 
  for (n = 0; n < rank; n++)
90 
    {
91 
      sstride[n] = array->dim[n].stride;
92 
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
93 
      count[n] = 0;
94 
      if (extent[n] <= 0)
95 
        {
96 
          /* Set the return value.  */
97 
          for (n = 0; n < rank; n++)
98 
            dest[n * dstride] = 0;
99 
          return;
100 
        }
101 
    }
102 
 
103 
  base = array->data;
104 
 
105 
  /* Initialize the return value.  */
106 
  for (n = 0; n < rank; n++)
107 
    dest[n * dstride] = 0;
108 
  {
109 
 
110 
  GFC_REAL_8 minval;
111 
 
112 
  minval = GFC_REAL_8_HUGE;
113 
 
114 
  while (base)
115 
    {
116 
      {
117 
        /* Implementation start.  */
118 
 
119 
  if (*base < minval || !dest[0])
120 
    {
121 
      minval = *base;
122 
      for (n = 0; n < rank; n++)
123 
        dest[n * dstride] = count[n] + 1;
124 
    }
125 
        /* Implementation end.  */
126 
      }
127 
      /* Advance to the next element.  */
128 
      count[0]++;
129 
      base += sstride[0];
130 
      n = 0;
131 
      while (count[n] == extent[n])
132 
        {
133 
          /* When we get to the end of a dimension, reset it and increment
134 
             the next dimension.  */
135 
          count[n] = 0;
136 
          /* We could precalculate these products, but this is a less
137 
             frequently used path so proabably not worth it.  */
138 
          base -= sstride[n] * extent[n];
139 
          n++;
140 
          if (n == rank)
141 
            {
142 
              /* Break out of the loop.  */
143 
              base = NULL;
144 
              break;
145 
            }
146 
          else
147 
            {
148 
              count[n]++;
149 
              base += sstride[n];
150 
            }
151 
        }
152 
    }
153 
  }
154 
}
155 
 
156 
 
157 
extern void mminloc0_4_r8 (gfc_array_i4 *, gfc_array_r8 *, gfc_array_l4 *);
158 
export_proto(mminloc0_4_r8);
159 
 
160 
void
161 
mminloc0_4_r8 (gfc_array_i4 * retarray, gfc_array_r8 *array,
162 
                                  gfc_array_l4 * mask)
163 
{
164 
  index_type count[GFC_MAX_DIMENSIONS];
165 
  index_type extent[GFC_MAX_DIMENSIONS];
166 
  index_type sstride[GFC_MAX_DIMENSIONS];
167 
  index_type mstride[GFC_MAX_DIMENSIONS];
168 
  index_type dstride;
169 
  GFC_INTEGER_4 *dest;
170 
  GFC_REAL_8 *base;
171 
  GFC_LOGICAL_4 *mbase;
172 
  int rank;
173 
  index_type n;
174 
 
175 
  rank = GFC_DESCRIPTOR_RANK (array);
176 
  if (rank <= 0)
177 
    runtime_error ("Rank of array needs to be > 0");
178 
 
179 
  if (retarray->data == NULL)
180 
    {
181 
      retarray->dim[0].lbound = 0;
182 
      retarray->dim[0].ubound = rank-1;
183 
      retarray->dim[0].stride = 1;
184 
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
185 
      retarray->offset = 0;
186 
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
187 
    }
188 
  else
189 
    {
190 
      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
191 
        runtime_error ("rank of return array does not equal 1");
192 
 
193 
      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
194 
        runtime_error ("dimension of return array incorrect");
195 
 
196 
      if (retarray->dim[0].stride == 0)
197 
        retarray->dim[0].stride = 1;
198 
    }
199 
 
200 
  /* TODO:  It should be a front end job to correctly set the strides.  */
201 
 
202 
  if (array->dim[0].stride == 0)
203 
    array->dim[0].stride = 1;
204 
 
205 
  if (mask->dim[0].stride == 0)
206 
    mask->dim[0].stride = 1;
207 
 
208 
  dstride = retarray->dim[0].stride;
209 
  dest = retarray->data;
210 
  for (n = 0; n < rank; n++)
211 
    {
212 
      sstride[n] = array->dim[n].stride;
213 
      mstride[n] = mask->dim[n].stride;
214 
      extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
215 
      count[n] = 0;
216 
      if (extent[n] <= 0)
217 
        {
218 
          /* Set the return value.  */
219 
          for (n = 0; n < rank; n++)
220 
            dest[n * dstride] = 0;
221 
          return;
222 
        }
223 
    }
224 
 
225 
  base = array->data;
226 
  mbase = mask->data;
227 
 
228 
  if (GFC_DESCRIPTOR_SIZE (mask) != 4)
229 
    {
230 
      /* This allows the same loop to be used for all logical types.  */
231 
      assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
232 
      for (n = 0; n < rank; n++)
233 
        mstride[n] <<= 1;
234 
      mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
235 
    }
236 
 
237 
 
238 
  /* Initialize the return value.  */
239 
  for (n = 0; n < rank; n++)
240 
    dest[n * dstride] = 0;
241 
  {
242 
 
243 
  GFC_REAL_8 minval;
244 
 
245 
  minval = GFC_REAL_8_HUGE;
246 
 
247 
  while (base)
248 
    {
249 
      {
250 
        /* Implementation start.  */
251 
 
252 
  if (*mbase && (*base < minval || !dest[0]))
253 
    {
254 
      minval = *base;
255 
      for (n = 0; n < rank; n++)
256 
        dest[n * dstride] = count[n] + 1;
257 
    }
258 
        /* Implementation end.  */
259 
      }
260 
      /* Advance to the next element.  */
261 
      count[0]++;
262 
      base += sstride[0];
263 
      mbase += mstride[0];
264 
      n = 0;
265 
      while (count[n] == extent[n])
266 
        {
267 
          /* When we get to the end of a dimension, reset it and increment
268 
             the next dimension.  */
269 
          count[n] = 0;
270 
          /* We could precalculate these products, but this is a less
271 
             frequently used path so proabably not worth it.  */
272 
          base -= sstride[n] * extent[n];
273 
          mbase -= mstride[n] * extent[n];
274 
          n++;
275 
          if (n == rank)
276 
            {
277 
              /* Break out of the loop.  */
278 
              base = NULL;
279 
              break;
280 
            }
281 
          else
282 
            {
283 
              count[n]++;
284 
              base += sstride[n];
285 
              mbase += mstride[n];
286 
            }
287 
        }
288 
    }
289 
  }
290 
}
291 
 
292 
 
293 
extern void sminloc0_4_r8 (gfc_array_i4 * const restrict,
294 
        gfc_array_r8 * const restrict, GFC_LOGICAL_4 *);
295 
export_proto(sminloc0_4_r8);
296 
 
297 
void
298 
sminloc0_4_r8 (gfc_array_i4 * const restrict retarray,
299 
        gfc_array_r8 * const restrict array,
300 
        GFC_LOGICAL_4 * mask)
301 
{
302 
  index_type rank;
303 
  index_type dstride;
304 
  index_type n;
305 
  GFC_INTEGER_4 *dest;
306 
 
307 
  if (*mask)
308 
    {
309 
      minloc0_4_r8 (retarray, array);
310 
      return;
311 
    }
312 
 
313 
  rank = GFC_DESCRIPTOR_RANK (array);
314 
 
315 
  if (rank <= 0)
316 
    runtime_error ("Rank of array needs to be > 0");
317 
 
318 
  if (retarray->data == NULL)
319 
    {
320 
      retarray->dim[0].lbound = 0;
321 
      retarray->dim[0].ubound = rank-1;
322 
      retarray->dim[0].stride = 1;
323 
      retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
324 
      retarray->offset = 0;
325 
      retarray->data = internal_malloc_size (sizeof (GFC_INTEGER_4) * rank);
326 
    }
327 
  else
328 
    {
329 
      if (GFC_DESCRIPTOR_RANK (retarray) != 1)
330 
        runtime_error ("rank of return array does not equal 1");
331 
 
332 
      if (retarray->dim[0].ubound + 1 - retarray->dim[0].lbound != rank)
333 
        runtime_error ("dimension of return array incorrect");
334 
 
335 
      if (retarray->dim[0].stride == 0)
336 
        retarray->dim[0].stride = 1;
337 
    }
338 
 
339 
  dstride = retarray->dim[0].stride;
340 
  dest = retarray->data;
341 
  for (n = 0; n<rank; n++)
342 
    dest[n * dstride] = 0 ;
343 
}
344 
#endif

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.