1 /* Implementation of the MAXVAL intrinsic
2 Copyright 2002, 2007, 2009 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 3 of the License, or (at your option) any later version.
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
26 #include "libgfortran.h"
31 #if defined (HAVE_GFC_INTEGER_8) && defined (HAVE_GFC_INTEGER_8)
34 extern void maxval_i8 (gfc_array_i8
* const restrict
,
35 gfc_array_i8
* const restrict
, const index_type
* const restrict
);
36 export_proto(maxval_i8
);
39 maxval_i8 (gfc_array_i8
* const restrict retarray
,
40 gfc_array_i8
* const restrict array
,
41 const index_type
* const restrict pdim
)
43 index_type count
[GFC_MAX_DIMENSIONS
];
44 index_type extent
[GFC_MAX_DIMENSIONS
];
45 index_type sstride
[GFC_MAX_DIMENSIONS
];
46 index_type dstride
[GFC_MAX_DIMENSIONS
];
47 const GFC_INTEGER_8
* restrict base
;
48 GFC_INTEGER_8
* restrict dest
;
56 /* Make dim zero based to avoid confusion. */
58 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
60 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
63 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
65 for (n
= 0; n
< dim
; n
++)
67 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
68 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
73 for (n
= dim
; n
< rank
; n
++)
75 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
76 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
82 if (retarray
->data
== NULL
)
84 size_t alloc_size
, str
;
86 for (n
= 0; n
< rank
; n
++)
91 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
93 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
98 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
100 alloc_size
= sizeof (GFC_INTEGER_8
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
105 /* Make sure we have a zero-sized array. */
106 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
111 retarray
->data
= internal_malloc_size (alloc_size
);
115 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
116 runtime_error ("rank of return array incorrect in"
117 " MAXVAL intrinsic: is %ld, should be %ld",
118 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
121 if (unlikely (compile_options
.bounds_check
))
122 bounds_ifunction_return ((array_t
*) retarray
, extent
,
123 "return value", "MAXVAL");
126 for (n
= 0; n
< rank
; n
++)
129 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
135 dest
= retarray
->data
;
138 while (continue_loop
)
140 const GFC_INTEGER_8
* restrict src
;
141 GFC_INTEGER_8 result
;
145 #if defined (GFC_INTEGER_8_INFINITY)
146 result
= -GFC_INTEGER_8_INFINITY
;
148 result
= (-GFC_INTEGER_8_HUGE
-1);
151 *dest
= (-GFC_INTEGER_8_HUGE
-1);
154 for (n
= 0; n
< len
; n
++, src
+= delta
)
157 #if defined (GFC_INTEGER_8_QUIET_NAN)
161 if (unlikely (n
>= len
))
162 result
= GFC_INTEGER_8_QUIET_NAN
;
163 else for (; 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_i8 (gfc_array_i8
* const restrict
,
205 gfc_array_i8
* const restrict
, const index_type
* const restrict
,
206 gfc_array_l1
* const restrict
);
207 export_proto(mmaxval_i8
);
210 mmaxval_i8 (gfc_array_i8
* const restrict retarray
,
211 gfc_array_i8
* 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_INTEGER_8
* restrict dest
;
221 const GFC_INTEGER_8
* restrict base
;
222 const GFC_LOGICAL_1
* restrict mbase
;
232 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
234 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
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
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
252 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
254 for (n
= 0; n
< dim
; n
++)
256 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
257 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
258 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
264 for (n
= dim
; n
< rank
; n
++)
266 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
267 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
268 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
274 if (retarray
->data
== NULL
)
276 size_t alloc_size
, str
;
278 for (n
= 0; n
< rank
; n
++)
283 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
285 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
289 alloc_size
= sizeof (GFC_INTEGER_8
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
292 retarray
->offset
= 0;
293 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
297 /* Make sure we have a zero-sized array. */
298 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
302 retarray
->data
= internal_malloc_size (alloc_size
);
307 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
308 runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
310 if (unlikely (compile_options
.bounds_check
))
312 bounds_ifunction_return ((array_t
*) retarray
, extent
,
313 "return value", "MAXVAL");
314 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
315 "MASK argument", "MAXVAL");
319 for (n
= 0; n
< rank
; n
++)
322 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
327 dest
= retarray
->data
;
332 const GFC_INTEGER_8
* restrict src
;
333 const GFC_LOGICAL_1
* restrict msrc
;
334 GFC_INTEGER_8 result
;
339 #if defined (GFC_INTEGER_8_INFINITY)
340 result
= -GFC_INTEGER_8_INFINITY
;
342 result
= (-GFC_INTEGER_8_HUGE
-1);
344 #if defined (GFC_INTEGER_8_QUIET_NAN)
348 *dest
= (-GFC_INTEGER_8_HUGE
-1);
351 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
354 #if defined (GFC_INTEGER_8_INFINITY) || defined (GFC_INTEGER_8_QUIET_NAN)
357 #if defined (GFC_INTEGER_8_QUIET_NAN)
364 if (unlikely (n
>= len
))
366 #if defined (GFC_INTEGER_8_QUIET_NAN)
367 result
= non_empty_p
? GFC_INTEGER_8_QUIET_NAN
: (-GFC_INTEGER_8_HUGE
-1);
369 result
= (-GFC_INTEGER_8_HUGE
-1);
372 else for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
375 if (*msrc
&& *src
> result
)
381 /* Advance to the next element. */
387 while (count
[n
] == extent
[n
])
389 /* When we get to the end of a dimension, reset it and increment
390 the next dimension. */
392 /* We could precalculate these products, but this is a less
393 frequently used path so probably not worth it. */
394 base
-= sstride
[n
] * extent
[n
];
395 mbase
-= mstride
[n
] * extent
[n
];
396 dest
-= dstride
[n
] * extent
[n
];
400 /* Break out of the look. */
416 extern void smaxval_i8 (gfc_array_i8
* const restrict
,
417 gfc_array_i8
* const restrict
, const index_type
* const restrict
,
419 export_proto(smaxval_i8
);
422 smaxval_i8 (gfc_array_i8
* const restrict retarray
,
423 gfc_array_i8
* const restrict array
,
424 const index_type
* const restrict pdim
,
425 GFC_LOGICAL_4
* mask
)
427 index_type count
[GFC_MAX_DIMENSIONS
];
428 index_type extent
[GFC_MAX_DIMENSIONS
];
429 index_type dstride
[GFC_MAX_DIMENSIONS
];
430 GFC_INTEGER_8
* restrict dest
;
438 maxval_i8 (retarray
, array
, pdim
);
441 /* Make dim zero based to avoid confusion. */
443 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
445 for (n
= 0; n
< dim
; n
++)
447 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
453 for (n
= dim
; n
< rank
; n
++)
456 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
462 if (retarray
->data
== NULL
)
464 size_t alloc_size
, str
;
466 for (n
= 0; n
< rank
; n
++)
471 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
473 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
477 retarray
->offset
= 0;
478 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
480 alloc_size
= sizeof (GFC_INTEGER_8
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
485 /* Make sure we have a zero-sized array. */
486 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
490 retarray
->data
= internal_malloc_size (alloc_size
);
494 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
495 runtime_error ("rank of return array incorrect in"
496 " MAXVAL intrinsic: is %ld, should be %ld",
497 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
500 if (unlikely (compile_options
.bounds_check
))
502 for (n
=0; n
< rank
; n
++)
504 index_type ret_extent
;
506 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
507 if (extent
[n
] != ret_extent
)
508 runtime_error ("Incorrect extent in return value of"
509 " MAXVAL intrinsic in dimension %ld:"
510 " is %ld, should be %ld", (long int) n
+ 1,
511 (long int) ret_extent
, (long int) extent
[n
]);
516 for (n
= 0; n
< rank
; n
++)
519 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
522 dest
= retarray
->data
;
526 *dest
= (-GFC_INTEGER_8_HUGE
-1);
530 while (count
[n
] == extent
[n
])
532 /* When we get to the end of a dimension, reset it and increment
533 the next dimension. */
535 /* We could precalculate these products, but this is a less
536 frequently used path so probably not worth it. */
537 dest
-= dstride
[n
] * extent
[n
];