OSDN Git Service

2005-05-04 Thomas Koenig <Thomas.Koenig@online.de>
[pf3gnuchains/gcc-fork.git] / libgfortran / generated / minval_r4.c
1 /* Implementation of the MINVAL 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., 59 Temple Place - Suite 330,
29 Boston, MA 02111-1307, USA.  */
30
31 #include "config.h"
32 #include <stdlib.h>
33 #include <assert.h>
34 #include <float.h>
35 #include "libgfortran.h"
36
37
38 extern void minval_r4 (gfc_array_r4 *, gfc_array_r4 *, index_type *);
39 export_proto(minval_r4);
40
41 void
42 minval_r4 (gfc_array_r4 *retarray, gfc_array_r4 *array, index_type *pdim)
43 {
44   index_type count[GFC_MAX_DIMENSIONS];
45   index_type extent[GFC_MAX_DIMENSIONS];
46   index_type sstride[GFC_MAX_DIMENSIONS];
47   index_type dstride[GFC_MAX_DIMENSIONS];
48   GFC_REAL_4 *base;
49   GFC_REAL_4 *dest;
50   index_type rank;
51   index_type n;
52   index_type len;
53   index_type delta;
54   index_type dim;
55
56   /* Make dim zero based to avoid confusion.  */
57   dim = (*pdim) - 1;
58   rank = GFC_DESCRIPTOR_RANK (array) - 1;
59
60   /* TODO:  It should be a front end job to correctly set the strides.  */
61
62   if (array->dim[0].stride == 0)
63     array->dim[0].stride = 1;
64
65   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
66   delta = array->dim[dim].stride;
67
68   for (n = 0; n < dim; n++)
69     {
70       sstride[n] = array->dim[n].stride;
71       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
72     }
73   for (n = dim; n < rank; n++)
74     {
75       sstride[n] = array->dim[n + 1].stride;
76       extent[n] =
77         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
78     }
79
80   if (retarray->data == NULL)
81     {
82       for (n = 0; n < rank; n++)
83         {
84           retarray->dim[n].lbound = 0;
85           retarray->dim[n].ubound = extent[n]-1;
86           if (n == 0)
87             retarray->dim[n].stride = 1;
88           else
89             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
90         }
91
92       retarray->data
93          = internal_malloc_size (sizeof (GFC_REAL_4)
94                                  * retarray->dim[rank-1].stride
95                                  * extent[rank-1]);
96       retarray->base = 0;
97       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
98     }
99   else
100     {
101       if (retarray->dim[0].stride == 0)
102         retarray->dim[0].stride = 1;
103
104       if (rank != GFC_DESCRIPTOR_RANK (retarray))
105         runtime_error ("rank of return array incorrect");
106     }
107
108   for (n = 0; n < rank; n++)
109     {
110       count[n] = 0;
111       dstride[n] = retarray->dim[n].stride;
112       if (extent[n] <= 0)
113         len = 0;
114     }
115
116   base = array->data;
117   dest = retarray->data;
118
119   while (base)
120     {
121       GFC_REAL_4 *src;
122       GFC_REAL_4 result;
123       src = base;
124       {
125
126   result = GFC_REAL_4_HUGE;
127         if (len <= 0)
128           *dest = GFC_REAL_4_HUGE;
129         else
130           {
131             for (n = 0; n < len; n++, src += delta)
132               {
133
134   if (*src < result)
135     result = *src;
136           }
137             *dest = result;
138           }
139       }
140       /* Advance to the next element.  */
141       count[0]++;
142       base += sstride[0];
143       dest += dstride[0];
144       n = 0;
145       while (count[n] == extent[n])
146         {
147           /* When we get to the end of a dimension, reset it and increment
148              the next dimension.  */
149           count[n] = 0;
150           /* We could precalculate these products, but this is a less
151              frequently used path so proabably not worth it.  */
152           base -= sstride[n] * extent[n];
153           dest -= dstride[n] * extent[n];
154           n++;
155           if (n == rank)
156             {
157               /* Break out of the look.  */
158               base = NULL;
159               break;
160             }
161           else
162             {
163               count[n]++;
164               base += sstride[n];
165               dest += dstride[n];
166             }
167         }
168     }
169 }
170
171
172 extern void mminval_r4 (gfc_array_r4 *, gfc_array_r4 *, index_type *,
173                                                gfc_array_l4 *);
174 export_proto(mminval_r4);
175
176 void
177 mminval_r4 (gfc_array_r4 * retarray, gfc_array_r4 * array,
178                                   index_type *pdim, gfc_array_l4 * mask)
179 {
180   index_type count[GFC_MAX_DIMENSIONS];
181   index_type extent[GFC_MAX_DIMENSIONS];
182   index_type sstride[GFC_MAX_DIMENSIONS];
183   index_type dstride[GFC_MAX_DIMENSIONS];
184   index_type mstride[GFC_MAX_DIMENSIONS];
185   GFC_REAL_4 *dest;
186   GFC_REAL_4 *base;
187   GFC_LOGICAL_4 *mbase;
188   int rank;
189   int dim;
190   index_type n;
191   index_type len;
192   index_type delta;
193   index_type mdelta;
194
195   dim = (*pdim) - 1;
196   rank = GFC_DESCRIPTOR_RANK (array) - 1;
197
198   /* TODO:  It should be a front end job to correctly set the strides.  */
199
200   if (array->dim[0].stride == 0)
201     array->dim[0].stride = 1;
202
203   if (mask->dim[0].stride == 0)
204     mask->dim[0].stride = 1;
205
206   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
207   if (len <= 0)
208     return;
209   delta = array->dim[dim].stride;
210   mdelta = mask->dim[dim].stride;
211
212   for (n = 0; n < dim; n++)
213     {
214       sstride[n] = array->dim[n].stride;
215       mstride[n] = mask->dim[n].stride;
216       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
217     }
218   for (n = dim; n < rank; n++)
219     {
220       sstride[n] = array->dim[n + 1].stride;
221       mstride[n] = mask->dim[n + 1].stride;
222       extent[n] =
223         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
224     }
225
226   if (retarray->data == NULL)
227     {
228       for (n = 0; n < rank; n++)
229         {
230           retarray->dim[n].lbound = 0;
231           retarray->dim[n].ubound = extent[n]-1;
232           if (n == 0)
233             retarray->dim[n].stride = 1;
234           else
235             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
236         }
237
238       retarray->data
239          = internal_malloc_size (sizeof (GFC_REAL_4)
240                                  * retarray->dim[rank-1].stride
241                                  * extent[rank-1]);
242       retarray->base = 0;
243       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
244     }
245   else
246     {
247       if (retarray->dim[0].stride == 0)
248         retarray->dim[0].stride = 1;
249
250       if (rank != GFC_DESCRIPTOR_RANK (retarray))
251         runtime_error ("rank of return array incorrect");
252     }
253
254   for (n = 0; n < rank; n++)
255     {
256       count[n] = 0;
257       dstride[n] = retarray->dim[n].stride;
258       if (extent[n] <= 0)
259         return;
260     }
261
262   dest = retarray->data;
263   base = array->data;
264   mbase = mask->data;
265
266   if (GFC_DESCRIPTOR_SIZE (mask) != 4)
267     {
268       /* This allows the same loop to be used for all logical types.  */
269       assert (GFC_DESCRIPTOR_SIZE (mask) == 8);
270       for (n = 0; n < rank; n++)
271         mstride[n] <<= 1;
272       mdelta <<= 1;
273       mbase = (GFOR_POINTER_L8_TO_L4 (mbase));
274     }
275
276   while (base)
277     {
278       GFC_REAL_4 *src;
279       GFC_LOGICAL_4 *msrc;
280       GFC_REAL_4 result;
281       src = base;
282       msrc = mbase;
283       {
284
285   result = GFC_REAL_4_HUGE;
286         if (len <= 0)
287           *dest = GFC_REAL_4_HUGE;
288         else
289           {
290             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
291               {
292
293   if (*msrc && *src < result)
294     result = *src;
295               }
296             *dest = result;
297           }
298       }
299       /* Advance to the next element.  */
300       count[0]++;
301       base += sstride[0];
302       mbase += mstride[0];
303       dest += dstride[0];
304       n = 0;
305       while (count[n] == extent[n])
306         {
307           /* When we get to the end of a dimension, reset it and increment
308              the next dimension.  */
309           count[n] = 0;
310           /* We could precalculate these products, but this is a less
311              frequently used path so proabably not worth it.  */
312           base -= sstride[n] * extent[n];
313           mbase -= mstride[n] * extent[n];
314           dest -= dstride[n] * extent[n];
315           n++;
316           if (n == rank)
317             {
318               /* Break out of the look.  */
319               base = NULL;
320               break;
321             }
322           else
323             {
324               count[n]++;
325               base += sstride[n];
326               mbase += mstride[n];
327               dest += dstride[n];
328             }
329         }
330     }
331 }
332