1 /* Implementation of the MINVAL 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_16) && defined (HAVE_GFC_REAL_16)
39 extern void minval_r16 (gfc_array_r16
* const restrict
,
40 gfc_array_r16
* const restrict
, const index_type
* const restrict
);
41 export_proto(minval_r16
);
44 minval_r16 (gfc_array_r16
* const restrict retarray
,
45 gfc_array_r16
* 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_16
* restrict base
;
53 GFC_REAL_16
* 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_16
) * 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 " MINVAL 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 " MINVAL 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_16
* restrict src
;
158 result
= GFC_REAL_16_HUGE
;
160 *dest
= GFC_REAL_16_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 mminval_r16 (gfc_array_r16
* const restrict
,
205 gfc_array_r16
* const restrict
, const index_type
* const restrict
,
206 gfc_array_l1
* const restrict
);
207 export_proto(mminval_r16
);
210 mminval_r16 (gfc_array_r16
* const restrict retarray
,
211 gfc_array_r16
* 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_16
* restrict dest
;
221 const GFC_REAL_16
* 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_16
) * 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 MINVAL 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 " MINVAL 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 " MINVAL 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_16
* restrict src
;
354 const GFC_LOGICAL_1
* restrict msrc
;
360 result
= GFC_REAL_16_HUGE
;
362 *dest
= GFC_REAL_16_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 sminval_r16 (gfc_array_r16
* const restrict
,
410 gfc_array_r16
* const restrict
, const index_type
* const restrict
,
412 export_proto(sminval_r16
);
415 sminval_r16 (gfc_array_r16
* const restrict retarray
,
416 gfc_array_r16
* const restrict array
,
417 const index_type
* const restrict pdim
,
418 GFC_LOGICAL_4
* mask
)
420 index_type count
[GFC_MAX_DIMENSIONS
];
421 index_type extent
[GFC_MAX_DIMENSIONS
];
422 index_type sstride
[GFC_MAX_DIMENSIONS
];
423 index_type dstride
[GFC_MAX_DIMENSIONS
];
424 GFC_REAL_16
* restrict dest
;
432 minval_r16 (retarray
, array
, pdim
);
435 /* Make dim zero based to avoid confusion. */
437 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
439 for (n
= 0; n
< dim
; n
++)
441 sstride
[n
] = array
->dim
[n
].stride
;
442 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
448 for (n
= dim
; n
< rank
; n
++)
450 sstride
[n
] = array
->dim
[n
+ 1].stride
;
452 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
458 if (retarray
->data
== NULL
)
462 for (n
= 0; n
< rank
; n
++)
464 retarray
->dim
[n
].lbound
= 0;
465 retarray
->dim
[n
].ubound
= extent
[n
]-1;
467 retarray
->dim
[n
].stride
= 1;
469 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
472 retarray
->offset
= 0;
473 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
475 alloc_size
= sizeof (GFC_REAL_16
) * retarray
->dim
[rank
-1].stride
480 /* Make sure we have a zero-sized array. */
481 retarray
->dim
[0].lbound
= 0;
482 retarray
->dim
[0].ubound
= -1;
486 retarray
->data
= internal_malloc_size (alloc_size
);
490 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
491 runtime_error ("rank of return array incorrect in"
492 " MINVAL intrinsic: is %ld, should be %ld",
493 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
496 if (compile_options
.bounds_check
)
498 for (n
=0; n
< rank
; n
++)
500 index_type ret_extent
;
502 ret_extent
= retarray
->dim
[n
].ubound
+ 1
503 - retarray
->dim
[n
].lbound
;
504 if (extent
[n
] != ret_extent
)
505 runtime_error ("Incorrect extent in return value of"
506 " MINVAL intrinsic in dimension %ld:"
507 " is %ld, should be %ld", (long int) n
+ 1,
508 (long int) ret_extent
, (long int) extent
[n
]);
513 for (n
= 0; n
< rank
; n
++)
516 dstride
[n
] = retarray
->dim
[n
].stride
;
519 dest
= retarray
->data
;
523 *dest
= GFC_REAL_16_HUGE
;
527 while (count
[n
] == extent
[n
])
529 /* When we get to the end of a dimension, reset it and increment
530 the next dimension. */
532 /* We could precalculate these products, but this is a less
533 frequently used path so probably not worth it. */
534 dest
-= dstride
[n
] * extent
[n
];