1 /* Implementation of the MAXVAL intrinsic
2 Copyright 2002, 2007 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. */
31 #include "libgfortran.h"
36 #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4)
39 extern void maxval_r4 (gfc_array_r4
* const restrict
,
40 gfc_array_r4
* const restrict
, const index_type
* const restrict
);
41 export_proto(maxval_r4
);
44 maxval_r4 (gfc_array_r4
* const restrict retarray
,
45 gfc_array_r4
* const restrict array
,
46 const index_type
* const restrict pdim
)
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
[GFC_MAX_DIMENSIONS
];
52 const GFC_REAL_4
* restrict base
;
53 GFC_REAL_4
* restrict dest
;
60 /* Make dim zero based to avoid confusion. */
62 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
64 len
= array
->dim
[dim
].ubound
+ 1 - array
->dim
[dim
].lbound
;
65 delta
= array
->dim
[dim
].stride
;
67 for (n
= 0; n
< dim
; n
++)
69 sstride
[n
] = array
->dim
[n
].stride
;
70 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
75 for (n
= dim
; n
< rank
; n
++)
77 sstride
[n
] = array
->dim
[n
+ 1].stride
;
79 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
85 if (retarray
->data
== NULL
)
89 for (n
= 0; n
< rank
; n
++)
91 retarray
->dim
[n
].lbound
= 0;
92 retarray
->dim
[n
].ubound
= extent
[n
]-1;
94 retarray
->dim
[n
].stride
= 1;
96 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
100 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
102 alloc_size
= sizeof (GFC_REAL_4
) * retarray
->dim
[rank
-1].stride
107 /* Make sure we have a zero-sized array. */
108 retarray
->dim
[0].lbound
= 0;
109 retarray
->dim
[0].ubound
= -1;
113 retarray
->data
= internal_malloc_size (alloc_size
);
117 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
118 runtime_error ("rank of return array incorrect in"
119 " MAXVAL intrinsic: is %ld, should be %ld",
120 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
123 if (compile_options
.bounds_check
)
125 for (n
=0; n
< rank
; n
++)
127 index_type ret_extent
;
129 ret_extent
= retarray
->dim
[n
].ubound
+ 1
130 - retarray
->dim
[n
].lbound
;
131 if (extent
[n
] != ret_extent
)
132 runtime_error ("Incorrect extent in return value of"
133 " MAXVAL intrinsic in dimension %ld:"
134 " is %ld, should be %ld", (long int) n
+ 1,
135 (long int) ret_extent
, (long int) extent
[n
]);
140 for (n
= 0; n
< rank
; n
++)
143 dstride
[n
] = retarray
->dim
[n
].stride
;
149 dest
= retarray
->data
;
153 const GFC_REAL_4
* restrict src
;
158 result
= -GFC_REAL_4_HUGE
;
160 *dest
= -GFC_REAL_4_HUGE
;
163 for (n
= 0; n
< len
; n
++, src
+= delta
)
172 /* Advance to the next element. */
177 while (count
[n
] == extent
[n
])
179 /* When we get to the end of a dimension, reset it and increment
180 the next dimension. */
182 /* We could precalculate these products, but this is a less
183 frequently used path so probably not worth it. */
184 base
-= sstride
[n
] * extent
[n
];
185 dest
-= dstride
[n
] * extent
[n
];
189 /* Break out of the look. */
204 extern void mmaxval_r4 (gfc_array_r4
* const restrict
,
205 gfc_array_r4
* const restrict
, const index_type
* const restrict
,
206 gfc_array_l1
* const restrict
);
207 export_proto(mmaxval_r4
);
210 mmaxval_r4 (gfc_array_r4
* const restrict retarray
,
211 gfc_array_r4
* const restrict array
,
212 const index_type
* const restrict pdim
,
213 gfc_array_l1
* const restrict mask
)
215 index_type count
[GFC_MAX_DIMENSIONS
];
216 index_type extent
[GFC_MAX_DIMENSIONS
];
217 index_type sstride
[GFC_MAX_DIMENSIONS
];
218 index_type dstride
[GFC_MAX_DIMENSIONS
];
219 index_type mstride
[GFC_MAX_DIMENSIONS
];
220 GFC_REAL_4
* restrict dest
;
221 const GFC_REAL_4
* restrict base
;
222 const GFC_LOGICAL_1
* restrict mbase
;
232 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
234 len
= array
->dim
[dim
].ubound
+ 1 - array
->dim
[dim
].lbound
;
240 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
242 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
243 #ifdef HAVE_GFC_LOGICAL_16
247 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
249 runtime_error ("Funny sized logical array");
251 delta
= array
->dim
[dim
].stride
;
252 mdelta
= mask
->dim
[dim
].stride
* mask_kind
;
254 for (n
= 0; n
< dim
; n
++)
256 sstride
[n
] = array
->dim
[n
].stride
;
257 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
258 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
264 for (n
= dim
; n
< rank
; n
++)
266 sstride
[n
] = array
->dim
[n
+ 1].stride
;
267 mstride
[n
] = mask
->dim
[n
+ 1].stride
* mask_kind
;
269 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
275 if (retarray
->data
== NULL
)
279 for (n
= 0; n
< rank
; n
++)
281 retarray
->dim
[n
].lbound
= 0;
282 retarray
->dim
[n
].ubound
= extent
[n
]-1;
284 retarray
->dim
[n
].stride
= 1;
286 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
289 alloc_size
= sizeof (GFC_REAL_4
) * retarray
->dim
[rank
-1].stride
292 retarray
->offset
= 0;
293 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
297 /* Make sure we have a zero-sized array. */
298 retarray
->dim
[0].lbound
= 0;
299 retarray
->dim
[0].ubound
= -1;
303 retarray
->data
= internal_malloc_size (alloc_size
);
308 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
309 runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
311 if (compile_options
.bounds_check
)
313 for (n
=0; n
< rank
; n
++)
315 index_type ret_extent
;
317 ret_extent
= retarray
->dim
[n
].ubound
+ 1
318 - retarray
->dim
[n
].lbound
;
319 if (extent
[n
] != ret_extent
)
320 runtime_error ("Incorrect extent in return value of"
321 " MAXVAL intrinsic in dimension %ld:"
322 " is %ld, should be %ld", (long int) n
+ 1,
323 (long int) ret_extent
, (long int) extent
[n
]);
325 for (n
=0; n
<= rank
; n
++)
327 index_type mask_extent
, array_extent
;
329 array_extent
= array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
330 mask_extent
= mask
->dim
[n
].ubound
+ 1 - mask
->dim
[n
].lbound
;
331 if (array_extent
!= mask_extent
)
332 runtime_error ("Incorrect extent in MASK argument of"
333 " MAXVAL intrinsic in dimension %ld:"
334 " is %ld, should be %ld", (long int) n
+ 1,
335 (long int) mask_extent
, (long int) array_extent
);
340 for (n
= 0; n
< rank
; n
++)
343 dstride
[n
] = retarray
->dim
[n
].stride
;
348 dest
= retarray
->data
;
353 const GFC_REAL_4
* restrict src
;
354 const GFC_LOGICAL_1
* restrict msrc
;
360 result
= -GFC_REAL_4_HUGE
;
362 *dest
= -GFC_REAL_4_HUGE
;
365 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
368 if (*msrc
&& *src
> result
)
374 /* Advance to the next element. */
380 while (count
[n
] == extent
[n
])
382 /* When we get to the end of a dimension, reset it and increment
383 the next dimension. */
385 /* We could precalculate these products, but this is a less
386 frequently used path so probably not worth it. */
387 base
-= sstride
[n
] * extent
[n
];
388 mbase
-= mstride
[n
] * extent
[n
];
389 dest
-= dstride
[n
] * extent
[n
];
393 /* Break out of the look. */
409 extern void smaxval_r4 (gfc_array_r4
* const restrict
,
410 gfc_array_r4
* const restrict
, const index_type
* const restrict
,
412 export_proto(smaxval_r4
);
415 smaxval_r4 (gfc_array_r4
* const restrict retarray
,
416 gfc_array_r4
* const restrict array
,
417 const index_type
* const restrict pdim
,
418 GFC_LOGICAL_4
* mask
)
427 maxval_r4 (retarray
, array
, pdim
);
430 rank
= GFC_DESCRIPTOR_RANK (array
);
432 runtime_error ("Rank of array needs to be > 0");
434 if (retarray
->data
== NULL
)
436 retarray
->dim
[0].lbound
= 0;
437 retarray
->dim
[0].ubound
= rank
-1;
438 retarray
->dim
[0].stride
= 1;
439 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
440 retarray
->offset
= 0;
441 retarray
->data
= internal_malloc_size (sizeof (GFC_REAL_4
) * rank
);
445 if (compile_options
.bounds_check
)
448 index_type ret_extent
;
450 ret_rank
= GFC_DESCRIPTOR_RANK (retarray
);
452 runtime_error ("rank of return array in MAXVAL intrinsic"
453 " should be 1, is %ld", (long int) ret_rank
);
455 ret_extent
= retarray
->dim
[0].ubound
+ 1 - retarray
->dim
[0].lbound
;
456 if (ret_extent
!= rank
)
457 runtime_error ("dimension of return array incorrect");
460 dstride
= retarray
->dim
[0].stride
;
461 dest
= retarray
->data
;
463 for (n
= 0; n
< rank
; n
++)
464 dest
[n
* dstride
] = -GFC_REAL_4_HUGE
;