1 /* Implementation of the MAXLOC intrinsic
2 Copyright (C) 2002-2018 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"
29 #if defined (HAVE_GFC_REAL_16) && defined (HAVE_GFC_INTEGER_16)
32 extern void maxloc0_16_r16 (gfc_array_i16
* const restrict retarray
,
33 gfc_array_r16
* const restrict array
);
34 export_proto(maxloc0_16_r16
);
37 maxloc0_16_r16 (gfc_array_i16
* const restrict retarray
,
38 gfc_array_r16
* const restrict array
)
40 index_type count
[GFC_MAX_DIMENSIONS
];
41 index_type extent
[GFC_MAX_DIMENSIONS
];
42 index_type sstride
[GFC_MAX_DIMENSIONS
];
44 const GFC_REAL_16
*base
;
45 GFC_INTEGER_16
* restrict dest
;
49 rank
= GFC_DESCRIPTOR_RANK (array
);
51 runtime_error ("Rank of array needs to be > 0");
53 if (retarray
->base_addr
== NULL
)
55 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
56 GFC_DTYPE_COPY_SETRANK(retarray
,retarray
,1);
58 retarray
->base_addr
= xmallocarray (rank
, sizeof (GFC_INTEGER_16
));
62 if (unlikely (compile_options
.bounds_check
))
63 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
67 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
68 dest
= retarray
->base_addr
;
69 for (n
= 0; n
< rank
; n
++)
71 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
72 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
76 /* Set the return value. */
77 for (n
= 0; n
< rank
; n
++)
78 dest
[n
* dstride
] = 0;
83 base
= array
->base_addr
;
85 /* Initialize the return value. */
86 for (n
= 0; n
< rank
; n
++)
87 dest
[n
* dstride
] = 1;
91 #if defined(GFC_REAL_16_QUIET_NAN)
95 #if defined(GFC_REAL_16_INFINITY)
96 maxval
= -GFC_REAL_16_INFINITY
;
98 maxval
= -GFC_REAL_16_HUGE
;
104 /* Implementation start. */
106 #if defined(GFC_REAL_16_QUIET_NAN)
109 if (unlikely (!fast
))
117 for (n
= 0; n
< rank
; n
++)
118 dest
[n
* dstride
] = count
[n
] + 1;
123 while (++count
[0] != extent
[0]);
133 for (n
= 0; n
< rank
; n
++)
134 dest
[n
* dstride
] = count
[n
] + 1;
136 /* Implementation end. */
137 /* Advance to the next element. */
140 while (++count
[0] != extent
[0]);
144 /* When we get to the end of a dimension, reset it and increment
145 the next dimension. */
147 /* We could precalculate these products, but this is a less
148 frequently used path so probably not worth it. */
149 base
-= sstride
[n
] * extent
[n
];
153 /* Break out of the loop. */
163 while (count
[n
] == extent
[n
]);
169 extern void mmaxloc0_16_r16 (gfc_array_i16
* const restrict
,
170 gfc_array_r16
* const restrict
, gfc_array_l1
* const restrict
);
171 export_proto(mmaxloc0_16_r16
);
174 mmaxloc0_16_r16 (gfc_array_i16
* const restrict retarray
,
175 gfc_array_r16
* const restrict array
,
176 gfc_array_l1
* const restrict mask
)
178 index_type count
[GFC_MAX_DIMENSIONS
];
179 index_type extent
[GFC_MAX_DIMENSIONS
];
180 index_type sstride
[GFC_MAX_DIMENSIONS
];
181 index_type mstride
[GFC_MAX_DIMENSIONS
];
183 GFC_INTEGER_16
*dest
;
184 const GFC_REAL_16
*base
;
185 GFC_LOGICAL_1
*mbase
;
190 rank
= GFC_DESCRIPTOR_RANK (array
);
192 runtime_error ("Rank of array needs to be > 0");
194 if (retarray
->base_addr
== NULL
)
196 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
- 1, 1);
197 GFC_DTYPE_COPY_SETRANK(retarray
,retarray
,1);
198 retarray
->offset
= 0;
199 retarray
->base_addr
= xmallocarray (rank
, sizeof (GFC_INTEGER_16
));
203 if (unlikely (compile_options
.bounds_check
))
206 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
208 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
209 "MASK argument", "MAXLOC");
213 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
215 mbase
= mask
->base_addr
;
217 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
218 #ifdef HAVE_GFC_LOGICAL_16
222 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
224 runtime_error ("Funny sized logical array");
226 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
227 dest
= retarray
->base_addr
;
228 for (n
= 0; n
< rank
; n
++)
230 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
231 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
232 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
236 /* Set the return value. */
237 for (n
= 0; n
< rank
; n
++)
238 dest
[n
* dstride
] = 0;
243 base
= array
->base_addr
;
245 /* Initialize the return value. */
246 for (n
= 0; n
< rank
; n
++)
247 dest
[n
* dstride
] = 0;
253 #if defined(GFC_REAL_16_INFINITY)
254 maxval
= -GFC_REAL_16_INFINITY
;
256 maxval
= -GFC_REAL_16_HUGE
;
262 /* Implementation start. */
266 if (unlikely (!fast
))
272 #if defined(GFC_REAL_16_QUIET_NAN)
273 if (unlikely (dest
[0] == 0))
274 for (n
= 0; n
< rank
; n
++)
275 dest
[n
* dstride
] = count
[n
] + 1;
281 for (n
= 0; n
< rank
; n
++)
282 dest
[n
* dstride
] = count
[n
] + 1;
289 while (++count
[0] != extent
[0]);
295 if (*mbase
&& *base
> maxval
)
298 for (n
= 0; n
< rank
; n
++)
299 dest
[n
* dstride
] = count
[n
] + 1;
301 /* Implementation end. */
302 /* Advance to the next element. */
306 while (++count
[0] != extent
[0]);
310 /* When we get to the end of a dimension, reset it and increment
311 the next dimension. */
313 /* We could precalculate these products, but this is a less
314 frequently used path so probably not worth it. */
315 base
-= sstride
[n
] * extent
[n
];
316 mbase
-= mstride
[n
] * extent
[n
];
320 /* Break out of the loop. */
331 while (count
[n
] == extent
[n
]);
337 extern void smaxloc0_16_r16 (gfc_array_i16
* const restrict
,
338 gfc_array_r16
* const restrict
, GFC_LOGICAL_4
*);
339 export_proto(smaxloc0_16_r16
);
342 smaxloc0_16_r16 (gfc_array_i16
* const restrict retarray
,
343 gfc_array_r16
* const restrict array
,
344 GFC_LOGICAL_4
* mask
)
349 GFC_INTEGER_16
*dest
;
353 maxloc0_16_r16 (retarray
, array
);
357 rank
= GFC_DESCRIPTOR_RANK (array
);
360 runtime_error ("Rank of array needs to be > 0");
362 if (retarray
->base_addr
== NULL
)
364 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
365 GFC_DTYPE_COPY_SETRANK(retarray
,retarray
,1);
366 retarray
->offset
= 0;
367 retarray
->base_addr
= xmallocarray (rank
, sizeof (GFC_INTEGER_16
));
369 else if (unlikely (compile_options
.bounds_check
))
371 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
375 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
376 dest
= retarray
->base_addr
;
377 for (n
= 0; n
<rank
; n
++)
378 dest
[n
* dstride
] = 0 ;