OSDN Git Service

7d2dc4175a6260f4ebc1d75e34418acfe7dcc5a5
[pf3gnuchains/gcc-fork.git] / libgfortran / generated / minloc1_8_r8.c
1 /* 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., 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 <limits.h>
36 #include "libgfortran.h"
37
38
39 extern void minloc1_8_r8 (gfc_array_i8 *, gfc_array_r8 *, index_type *);
40 export_proto(minloc1_8_r8);
41
42 void
43 minloc1_8_r8 (gfc_array_i8 *retarray, gfc_array_r8 *array, index_type *pdim)
44 {
45   index_type count[GFC_MAX_DIMENSIONS - 1];
46   index_type extent[GFC_MAX_DIMENSIONS - 1];
47   index_type sstride[GFC_MAX_DIMENSIONS - 1];
48   index_type dstride[GFC_MAX_DIMENSIONS - 1];
49   GFC_REAL_8 *base;
50   GFC_INTEGER_8 *dest;
51   index_type rank;
52   index_type n;
53   index_type len;
54   index_type delta;
55   index_type dim;
56
57   /* Make dim zero based to avoid confusion.  */
58   dim = (*pdim) - 1;
59   rank = GFC_DESCRIPTOR_RANK (array) - 1;
60   if (array->dim[0].stride == 0)
61     array->dim[0].stride = 1;
62
63   len = array->dim[dim].ubound + 1 - array->dim[dim].lbound;
64   delta = array->dim[dim].stride;
65
66   for (n = 0; n < dim; n++)
67     {
68       sstride[n] = array->dim[n].stride;
69       extent[n] = array->dim[n].ubound + 1 - array->dim[n].lbound;
70     }
71   for (n = dim; n < rank; n++)
72     {
73       sstride[n] = array->dim[n + 1].stride;
74       extent[n] =
75         array->dim[n + 1].ubound + 1 - array->dim[n + 1].lbound;
76     }
77
78   if (retarray->data == NULL)
79     {
80       for (n = 0; n < rank; n++)
81         {
82           retarray->dim[n].lbound = 0;
83           retarray->dim[n].ubound = extent[n]-1;
84           if (n == 0)
85             retarray->dim[n].stride = 1;
86           else
87             retarray->dim[n].stride = retarray->dim[n-1].stride * extent[n-1];
88         }
89
90       retarray->data
91          = internal_malloc_size (sizeof (GFC_INTEGER_8)
92                                  * retarray->dim[rank-1].stride
93                                  * extent[rank-1]);
94       retarray->base = 0;
95       retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank;
96     }
97   else
98     {
99       if (retarray->dim[0].stride == 0)
100         retarray->dim[0].stride = 1;
101
102       if (rank != GFC_DESCRIPTOR_RANK (retarray))
103         runtime_error ("rank of return array incorrect");
104     }
105
106   for (n = 0; n < rank; n++)
107     {
108       count[n] = 0;
109       dstride[n] = retarray->dim[n].stride;
110       if (extent[n] <= 0)
111         len = 0;
112     }
113
114   base = array->data;
115   dest = retarray->data;
116
117   while (base)
118     {
119       GFC_REAL_8 *src;
120       GFC_INTEGER_8 result;
121       src = base;
122       {
123
124   GFC_REAL_8 minval;
125   minval = GFC_REAL_8_HUGE;
126   result = 1;
127         if (len <= 0)
128           *dest = 0;
129         else
130           {
131             for (n = 0; n < len; n++, src += delta)
132               {
133
134   if (*src < minval)
135     {
136       minval = *src;
137       result = (GFC_INTEGER_8)n + 1;
138     }
139           }
140             *dest = result;
141           }
142       }
143       /* Advance to the next element.  */
144       count[0]++;
145       base += sstride[0];
146       dest += dstride[0];
147       n = 0;
148       while (count[n] == extent[n])
149         {
150           /* When we get to the end of a dimension, reset it and increment
151              the next dimension.  */
152           count[n] = 0;
153           /* We could precalculate these products, but this is a less
154              frequently used path so proabably not worth it.  */
155           base -= sstride[n] * extent[n];
156           dest -= dstride[n] * extent[n];
157           n++;
158           if (n == rank)
159             {
160               /* Break out of the look.  */
161               base = NULL;
162               break;
163             }
164           else
165             {
166               count[n]++;
167               base += sstride[n];
168               dest += dstride[n];
169             }
170         }
171     }
172 }
173
174
175 extern void mminloc1_8_r8 (gfc_array_i8 *, gfc_array_r8 *, index_type *,
176                                                gfc_array_l4 *);
177 export_proto(mminloc1_8_r8);
178
179 void
180 mminloc1_8_r8 (gfc_array_i8 * retarray, gfc_array_r8 * array,
181                                   index_type *pdim, gfc_array_l4 * mask)
182 {
183   index_type count[GFC_MAX_DIMENSIONS - 1];
184   index_type extent[GFC_MAX_DIMENSIONS - 1];
185   index_type sstride[GFC_MAX_DIMENSIONS - 1];
186   index_type dstride[GFC_MAX_DIMENSIONS - 1];
187   index_type mstride[GFC_MAX_DIMENSIONS - 1];
188   GFC_INTEGER_8 *dest;
189   GFC_REAL_8 *base;
190   GFC_LOGICAL_4 *mbase;
191   int rank;
192   int dim;
193   index_type n;
194   index_type len;
195   index_type delta;
196   index_type mdelta;
197
198   dim = (*pdim) - 1;
199   rank = GFC_DESCRIPTOR_RANK (array) - 1;
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_INTEGER_8)
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_8 *src;
279       GFC_LOGICAL_4 *msrc;
280       GFC_INTEGER_8 result;
281       src = base;
282       msrc = mbase;
283       {
284
285   GFC_REAL_8 minval;
286   minval = GFC_REAL_8_HUGE;
287   result = 1;
288         if (len <= 0)
289           *dest = 0;
290         else
291           {
292             for (n = 0; n < len; n++, src += delta, msrc += mdelta)
293               {
294
295   if (*msrc && *src < minval)
296     {
297       minval = *src;
298       result = (GFC_INTEGER_8)n + 1;
299     }
300               }
301             *dest = result;
302           }
303       }
304       /* Advance to the next element.  */
305       count[0]++;
306       base += sstride[0];
307       mbase += mstride[0];
308       dest += dstride[0];
309       n = 0;
310       while (count[n] == extent[n])
311         {
312           /* When we get to the end of a dimension, reset it and increment
313              the next dimension.  */
314           count[n] = 0;
315           /* We could precalculate these products, but this is a less
316              frequently used path so proabably not worth it.  */
317           base -= sstride[n] * extent[n];
318           mbase -= mstride[n] * extent[n];
319           dest -= dstride[n] * extent[n];
320           n++;
321           if (n == rank)
322             {
323               /* Break out of the look.  */
324               base = NULL;
325               break;
326             }
327           else
328             {
329               count[n]++;
330               base += sstride[n];
331               mbase += mstride[n];
332               dest += dstride[n];
333             }
334         }
335     }
336 }
337