1 /* Implementation of the MAXVAL 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. */
34 #include "libgfortran.h"
37 #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
40 extern void maxval_i4 (gfc_array_i4
* const restrict
,
41 gfc_array_i4
* const restrict
, const index_type
* const restrict
);
42 export_proto(maxval_i4
);
45 maxval_i4 (gfc_array_i4
* const restrict retarray
,
46 gfc_array_i4
* const restrict array
,
47 const index_type
* const restrict pdim
)
49 index_type count
[GFC_MAX_DIMENSIONS
];
50 index_type extent
[GFC_MAX_DIMENSIONS
];
51 index_type sstride
[GFC_MAX_DIMENSIONS
];
52 index_type dstride
[GFC_MAX_DIMENSIONS
];
53 const GFC_INTEGER_4
* restrict base
;
54 GFC_INTEGER_4
* restrict dest
;
61 /* Make dim zero based to avoid confusion. */
63 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
65 len
= array
->dim
[dim
].ubound
+ 1 - array
->dim
[dim
].lbound
;
66 delta
= array
->dim
[dim
].stride
;
68 for (n
= 0; n
< dim
; n
++)
70 sstride
[n
] = array
->dim
[n
].stride
;
71 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
76 for (n
= dim
; n
< rank
; n
++)
78 sstride
[n
] = array
->dim
[n
+ 1].stride
;
80 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
86 if (retarray
->data
== NULL
)
90 for (n
= 0; n
< rank
; n
++)
92 retarray
->dim
[n
].lbound
= 0;
93 retarray
->dim
[n
].ubound
= extent
[n
]-1;
95 retarray
->dim
[n
].stride
= 1;
97 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
100 retarray
->offset
= 0;
101 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
103 alloc_size
= sizeof (GFC_INTEGER_4
) * retarray
->dim
[rank
-1].stride
108 /* Make sure we have a zero-sized array. */
109 retarray
->dim
[0].lbound
= 0;
110 retarray
->dim
[0].ubound
= -1;
114 retarray
->data
= internal_malloc_size (alloc_size
);
118 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
119 runtime_error ("rank of return array incorrect");
122 for (n
= 0; n
< rank
; n
++)
125 dstride
[n
] = retarray
->dim
[n
].stride
;
131 dest
= retarray
->data
;
135 const GFC_INTEGER_4
* restrict src
;
136 GFC_INTEGER_4 result
;
140 result
= (-GFC_INTEGER_4_HUGE
-1);
142 *dest
= (-GFC_INTEGER_4_HUGE
-1);
145 for (n
= 0; n
< len
; n
++, src
+= delta
)
154 /* Advance to the next element. */
159 while (count
[n
] == extent
[n
])
161 /* When we get to the end of a dimension, reset it and increment
162 the next dimension. */
164 /* We could precalculate these products, but this is a less
165 frequently used path so probably not worth it. */
166 base
-= sstride
[n
] * extent
[n
];
167 dest
-= dstride
[n
] * extent
[n
];
171 /* Break out of the look. */
186 extern void mmaxval_i4 (gfc_array_i4
* const restrict
,
187 gfc_array_i4
* const restrict
, const index_type
* const restrict
,
188 gfc_array_l4
* const restrict
);
189 export_proto(mmaxval_i4
);
192 mmaxval_i4 (gfc_array_i4
* const restrict retarray
,
193 gfc_array_i4
* const restrict array
,
194 const index_type
* const restrict pdim
,
195 gfc_array_l4
* const restrict mask
)
197 index_type count
[GFC_MAX_DIMENSIONS
];
198 index_type extent
[GFC_MAX_DIMENSIONS
];
199 index_type sstride
[GFC_MAX_DIMENSIONS
];
200 index_type dstride
[GFC_MAX_DIMENSIONS
];
201 index_type mstride
[GFC_MAX_DIMENSIONS
];
202 GFC_INTEGER_4
* restrict dest
;
203 const GFC_INTEGER_4
* restrict base
;
204 const GFC_LOGICAL_4
* restrict mbase
;
213 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
215 len
= array
->dim
[dim
].ubound
+ 1 - array
->dim
[dim
].lbound
;
218 delta
= array
->dim
[dim
].stride
;
219 mdelta
= mask
->dim
[dim
].stride
;
221 for (n
= 0; n
< dim
; n
++)
223 sstride
[n
] = array
->dim
[n
].stride
;
224 mstride
[n
] = mask
->dim
[n
].stride
;
225 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
231 for (n
= dim
; n
< rank
; n
++)
233 sstride
[n
] = array
->dim
[n
+ 1].stride
;
234 mstride
[n
] = mask
->dim
[n
+ 1].stride
;
236 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
242 if (retarray
->data
== NULL
)
246 for (n
= 0; n
< rank
; n
++)
248 retarray
->dim
[n
].lbound
= 0;
249 retarray
->dim
[n
].ubound
= extent
[n
]-1;
251 retarray
->dim
[n
].stride
= 1;
253 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
256 alloc_size
= sizeof (GFC_INTEGER_4
) * retarray
->dim
[rank
-1].stride
259 retarray
->offset
= 0;
260 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
264 /* Make sure we have a zero-sized array. */
265 retarray
->dim
[0].lbound
= 0;
266 retarray
->dim
[0].ubound
= -1;
270 retarray
->data
= internal_malloc_size (alloc_size
);
275 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
276 runtime_error ("rank of return array incorrect");
279 for (n
= 0; n
< rank
; n
++)
282 dstride
[n
] = retarray
->dim
[n
].stride
;
287 dest
= retarray
->data
;
291 if (GFC_DESCRIPTOR_SIZE (mask
) != 4)
293 /* This allows the same loop to be used for all logical types. */
294 assert (GFC_DESCRIPTOR_SIZE (mask
) == 8);
295 for (n
= 0; n
< rank
; n
++)
298 mbase
= (GFOR_POINTER_L8_TO_L4 (mbase
));
303 const GFC_INTEGER_4
* restrict src
;
304 const GFC_LOGICAL_4
* restrict msrc
;
305 GFC_INTEGER_4 result
;
310 result
= (-GFC_INTEGER_4_HUGE
-1);
312 *dest
= (-GFC_INTEGER_4_HUGE
-1);
315 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
318 if (*msrc
&& *src
> result
)
324 /* Advance to the next element. */
330 while (count
[n
] == extent
[n
])
332 /* When we get to the end of a dimension, reset it and increment
333 the next dimension. */
335 /* We could precalculate these products, but this is a less
336 frequently used path so probably not worth it. */
337 base
-= sstride
[n
] * extent
[n
];
338 mbase
-= mstride
[n
] * extent
[n
];
339 dest
-= dstride
[n
] * extent
[n
];
343 /* Break out of the look. */
359 extern void smaxval_i4 (gfc_array_i4
* const restrict
,
360 gfc_array_i4
* const restrict
, const index_type
* const restrict
,
362 export_proto(smaxval_i4
);
365 smaxval_i4 (gfc_array_i4
* const restrict retarray
,
366 gfc_array_i4
* const restrict array
,
367 const index_type
* const restrict pdim
,
368 GFC_LOGICAL_4
* mask
)
377 maxval_i4 (retarray
, array
, pdim
);
380 rank
= GFC_DESCRIPTOR_RANK (array
);
382 runtime_error ("Rank of array needs to be > 0");
384 if (retarray
->data
== NULL
)
386 retarray
->dim
[0].lbound
= 0;
387 retarray
->dim
[0].ubound
= rank
-1;
388 retarray
->dim
[0].stride
= 1;
389 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
390 retarray
->offset
= 0;
391 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_4
) * rank
);
395 if (GFC_DESCRIPTOR_RANK (retarray
) != 1)
396 runtime_error ("rank of return array does not equal 1");
398 if (retarray
->dim
[0].ubound
+ 1 - retarray
->dim
[0].lbound
!= rank
)
399 runtime_error ("dimension of return array incorrect");
402 dstride
= retarray
->dim
[0].stride
;
403 dest
= retarray
->data
;
405 for (n
= 0; n
< rank
; n
++)
406 dest
[n
* dstride
] = (-GFC_INTEGER_4_HUGE
-1) ;