1 /* Implementation of the MINLOC intrinsic
2 Copyright (C) 2002-2017 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 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_4) && defined (HAVE_GFC_INTEGER_4)
32 extern void minloc1_4_r4 (gfc_array_i4
* const restrict
,
33 gfc_array_r4
* const restrict
, const index_type
* const restrict
);
34 export_proto(minloc1_4_r4
);
37 minloc1_4_r4 (gfc_array_i4
* const restrict retarray
,
38 gfc_array_r4
* const restrict array
,
39 const index_type
* const restrict pdim
)
41 index_type count
[GFC_MAX_DIMENSIONS
];
42 index_type extent
[GFC_MAX_DIMENSIONS
];
43 index_type sstride
[GFC_MAX_DIMENSIONS
];
44 index_type dstride
[GFC_MAX_DIMENSIONS
];
45 const GFC_REAL_4
* restrict base
;
46 GFC_INTEGER_4
* restrict dest
;
54 /* Make dim zero based to avoid confusion. */
56 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
58 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
61 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
63 for (n
= 0; n
< dim
; n
++)
65 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
66 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
71 for (n
= dim
; n
< rank
; n
++)
73 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
74 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
80 if (retarray
->base_addr
== NULL
)
82 size_t alloc_size
, str
;
84 for (n
= 0; n
< rank
; n
++)
89 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
91 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
96 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
98 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
100 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
103 /* Make sure we have a zero-sized array. */
104 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
111 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
112 runtime_error ("rank of return array incorrect in"
113 " MINLOC intrinsic: is %ld, should be %ld",
114 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
117 if (unlikely (compile_options
.bounds_check
))
118 bounds_ifunction_return ((array_t
*) retarray
, extent
,
119 "return value", "MINLOC");
122 for (n
= 0; n
< rank
; n
++)
125 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
130 base
= array
->base_addr
;
131 dest
= retarray
->base_addr
;
134 while (continue_loop
)
136 const GFC_REAL_4
* restrict src
;
137 GFC_INTEGER_4 result
;
142 #if defined (GFC_REAL_4_INFINITY)
143 minval
= GFC_REAL_4_INFINITY
;
145 minval
= GFC_REAL_4_HUGE
;
152 for (n
= 0; n
< len
; n
++, src
+= delta
)
155 #if defined (GFC_REAL_4_QUIET_NAN)
159 result
= (GFC_INTEGER_4
)n
+ 1;
163 for (; n
< len
; n
++, src
+= delta
)
169 result
= (GFC_INTEGER_4
)n
+ 1;
176 /* Advance to the next element. */
181 while (count
[n
] == extent
[n
])
183 /* When we get to the end of a dimension, reset it and increment
184 the next dimension. */
186 /* We could precalculate these products, but this is a less
187 frequently used path so probably not worth it. */
188 base
-= sstride
[n
] * extent
[n
];
189 dest
-= dstride
[n
] * extent
[n
];
193 /* Break out of the loop. */
208 extern void mminloc1_4_r4 (gfc_array_i4
* const restrict
,
209 gfc_array_r4
* const restrict
, const index_type
* const restrict
,
210 gfc_array_l1
* const restrict
);
211 export_proto(mminloc1_4_r4
);
214 mminloc1_4_r4 (gfc_array_i4
* const restrict retarray
,
215 gfc_array_r4
* const restrict array
,
216 const index_type
* const restrict pdim
,
217 gfc_array_l1
* const restrict mask
)
219 index_type count
[GFC_MAX_DIMENSIONS
];
220 index_type extent
[GFC_MAX_DIMENSIONS
];
221 index_type sstride
[GFC_MAX_DIMENSIONS
];
222 index_type dstride
[GFC_MAX_DIMENSIONS
];
223 index_type mstride
[GFC_MAX_DIMENSIONS
];
224 GFC_INTEGER_4
* restrict dest
;
225 const GFC_REAL_4
* restrict base
;
226 const GFC_LOGICAL_1
* restrict mbase
;
236 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
238 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
242 mbase
= mask
->base_addr
;
244 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
246 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
247 #ifdef HAVE_GFC_LOGICAL_16
251 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
253 runtime_error ("Funny sized logical array");
255 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
256 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
258 for (n
= 0; n
< dim
; n
++)
260 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
261 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
262 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
268 for (n
= dim
; n
< rank
; n
++)
270 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
271 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
272 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
278 if (retarray
->base_addr
== NULL
)
280 size_t alloc_size
, str
;
282 for (n
= 0; n
< rank
; n
++)
287 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
289 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
293 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
295 retarray
->offset
= 0;
296 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
300 /* Make sure we have a zero-sized array. */
301 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
305 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
310 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
311 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
313 if (unlikely (compile_options
.bounds_check
))
315 bounds_ifunction_return ((array_t
*) retarray
, extent
,
316 "return value", "MINLOC");
317 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
318 "MASK argument", "MINLOC");
322 for (n
= 0; n
< rank
; n
++)
325 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
330 dest
= retarray
->base_addr
;
331 base
= array
->base_addr
;
335 const GFC_REAL_4
* restrict src
;
336 const GFC_LOGICAL_1
* restrict msrc
;
337 GFC_INTEGER_4 result
;
343 #if defined (GFC_REAL_4_INFINITY)
344 minval
= GFC_REAL_4_INFINITY
;
346 minval
= GFC_REAL_4_HUGE
;
348 #if defined (GFC_REAL_4_QUIET_NAN)
349 GFC_INTEGER_4 result2
= 0;
352 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
357 #if defined (GFC_REAL_4_QUIET_NAN)
359 result2
= (GFC_INTEGER_4
)n
+ 1;
364 result
= (GFC_INTEGER_4
)n
+ 1;
369 #if defined (GFC_REAL_4_QUIET_NAN)
370 if (unlikely (n
>= len
))
374 for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
376 if (*msrc
&& *src
< minval
)
379 result
= (GFC_INTEGER_4
)n
+ 1;
384 /* Advance to the next element. */
390 while (count
[n
] == extent
[n
])
392 /* When we get to the end of a dimension, reset it and increment
393 the next dimension. */
395 /* We could precalculate these products, but this is a less
396 frequently used path so probably not worth it. */
397 base
-= sstride
[n
] * extent
[n
];
398 mbase
-= mstride
[n
] * extent
[n
];
399 dest
-= dstride
[n
] * extent
[n
];
403 /* Break out of the loop. */
419 extern void sminloc1_4_r4 (gfc_array_i4
* const restrict
,
420 gfc_array_r4
* const restrict
, const index_type
* const restrict
,
422 export_proto(sminloc1_4_r4
);
425 sminloc1_4_r4 (gfc_array_i4
* const restrict retarray
,
426 gfc_array_r4
* const restrict array
,
427 const index_type
* const restrict pdim
,
428 GFC_LOGICAL_4
* mask
)
430 index_type count
[GFC_MAX_DIMENSIONS
];
431 index_type extent
[GFC_MAX_DIMENSIONS
];
432 index_type dstride
[GFC_MAX_DIMENSIONS
];
433 GFC_INTEGER_4
* restrict dest
;
441 minloc1_4_r4 (retarray
, array
, pdim
);
444 /* Make dim zero based to avoid confusion. */
446 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
448 for (n
= 0; n
< dim
; n
++)
450 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
456 for (n
= dim
; n
< rank
; n
++)
459 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
465 if (retarray
->base_addr
== NULL
)
467 size_t alloc_size
, str
;
469 for (n
= 0; n
< rank
; n
++)
474 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
476 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
480 retarray
->offset
= 0;
481 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
483 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
487 /* Make sure we have a zero-sized array. */
488 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
492 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_INTEGER_4
));
496 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
497 runtime_error ("rank of return array incorrect in"
498 " MINLOC intrinsic: is %ld, should be %ld",
499 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
502 if (unlikely (compile_options
.bounds_check
))
504 for (n
=0; n
< rank
; n
++)
506 index_type ret_extent
;
508 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
509 if (extent
[n
] != ret_extent
)
510 runtime_error ("Incorrect extent in return value of"
511 " MINLOC intrinsic in dimension %ld:"
512 " is %ld, should be %ld", (long int) n
+ 1,
513 (long int) ret_extent
, (long int) extent
[n
]);
518 for (n
= 0; n
< rank
; n
++)
521 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
524 dest
= retarray
->base_addr
;
532 while (count
[n
] == extent
[n
])
534 /* When we get to the end of a dimension, reset it and increment
535 the next dimension. */
537 /* We could precalculate these products, but this is a less
538 frequently used path so probably not worth it. */
539 dest
-= dstride
[n
] * extent
[n
];