1 /* Implementation of the MINLOC 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"
32 #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_INTEGER_4)
35 extern void minloc0_4_r4 (gfc_array_i4
* const restrict retarray
,
36 gfc_array_r4
* const restrict array
);
37 export_proto(minloc0_4_r4
);
40 minloc0_4_r4 (gfc_array_i4
* const restrict retarray
,
41 gfc_array_r4
* const restrict array
)
43 index_type count
[GFC_MAX_DIMENSIONS
];
44 index_type extent
[GFC_MAX_DIMENSIONS
];
45 index_type sstride
[GFC_MAX_DIMENSIONS
];
47 const GFC_REAL_4
*base
;
48 GFC_INTEGER_4
* restrict dest
;
52 rank
= GFC_DESCRIPTOR_RANK (array
);
54 runtime_error ("Rank of array needs to be > 0");
56 if (retarray
->data
== NULL
)
58 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
59 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
61 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_4
) * rank
);
65 if (unlikely (compile_options
.bounds_check
))
66 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
70 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
71 dest
= retarray
->data
;
72 for (n
= 0; n
< rank
; n
++)
74 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
75 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
79 /* Set the return value. */
80 for (n
= 0; n
< rank
; n
++)
81 dest
[n
* dstride
] = 0;
88 /* Initialize the return value. */
89 for (n
= 0; n
< rank
; n
++)
90 dest
[n
* dstride
] = 0;
95 minval
= GFC_REAL_4_HUGE
;
100 /* Implementation start. */
102 if (*base
< minval
|| !dest
[0])
105 for (n
= 0; n
< rank
; n
++)
106 dest
[n
* dstride
] = count
[n
] + 1;
108 /* Implementation end. */
110 /* Advance to the next element. */
114 while (count
[n
] == extent
[n
])
116 /* When we get to the end of a dimension, reset it and increment
117 the next dimension. */
119 /* We could precalculate these products, but this is a less
120 frequently used path so probably not worth it. */
121 base
-= sstride
[n
] * extent
[n
];
125 /* Break out of the loop. */
140 extern void mminloc0_4_r4 (gfc_array_i4
* const restrict
,
141 gfc_array_r4
* const restrict
, gfc_array_l1
* const restrict
);
142 export_proto(mminloc0_4_r4
);
145 mminloc0_4_r4 (gfc_array_i4
* const restrict retarray
,
146 gfc_array_r4
* const restrict array
,
147 gfc_array_l1
* const restrict mask
)
149 index_type count
[GFC_MAX_DIMENSIONS
];
150 index_type extent
[GFC_MAX_DIMENSIONS
];
151 index_type sstride
[GFC_MAX_DIMENSIONS
];
152 index_type mstride
[GFC_MAX_DIMENSIONS
];
155 const GFC_REAL_4
*base
;
156 GFC_LOGICAL_1
*mbase
;
161 rank
= GFC_DESCRIPTOR_RANK (array
);
163 runtime_error ("Rank of array needs to be > 0");
165 if (retarray
->data
== NULL
)
167 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
- 1, 1);
168 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
169 retarray
->offset
= 0;
170 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_4
) * rank
);
174 if (unlikely (compile_options
.bounds_check
))
177 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
179 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
180 "MASK argument", "MINLOC");
184 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
188 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
189 #ifdef HAVE_GFC_LOGICAL_16
193 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
195 runtime_error ("Funny sized logical array");
197 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
198 dest
= retarray
->data
;
199 for (n
= 0; n
< rank
; n
++)
201 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
202 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
203 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
207 /* Set the return value. */
208 for (n
= 0; n
< rank
; n
++)
209 dest
[n
* dstride
] = 0;
216 /* Initialize the return value. */
217 for (n
= 0; n
< rank
; n
++)
218 dest
[n
* dstride
] = 0;
223 minval
= GFC_REAL_4_HUGE
;
228 /* Implementation start. */
230 if (*mbase
&& (*base
< minval
|| !dest
[0]))
233 for (n
= 0; n
< rank
; n
++)
234 dest
[n
* dstride
] = count
[n
] + 1;
236 /* Implementation end. */
238 /* Advance to the next element. */
243 while (count
[n
] == extent
[n
])
245 /* When we get to the end of a dimension, reset it and increment
246 the next dimension. */
248 /* We could precalculate these products, but this is a less
249 frequently used path so probably not worth it. */
250 base
-= sstride
[n
] * extent
[n
];
251 mbase
-= mstride
[n
] * extent
[n
];
255 /* Break out of the loop. */
271 extern void sminloc0_4_r4 (gfc_array_i4
* const restrict
,
272 gfc_array_r4
* const restrict
, GFC_LOGICAL_4
*);
273 export_proto(sminloc0_4_r4
);
276 sminloc0_4_r4 (gfc_array_i4
* const restrict retarray
,
277 gfc_array_r4
* const restrict array
,
278 GFC_LOGICAL_4
* mask
)
287 minloc0_4_r4 (retarray
, array
);
291 rank
= GFC_DESCRIPTOR_RANK (array
);
294 runtime_error ("Rank of array needs to be > 0");
296 if (retarray
->data
== NULL
)
298 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
299 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
300 retarray
->offset
= 0;
301 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_4
) * rank
);
303 else if (unlikely (compile_options
.bounds_check
))
305 bounds_iforeach_return ((array_t
*) retarray
, (array_t
*) array
,
309 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
310 dest
= retarray
->data
;
311 for (n
= 0; n
<rank
; n
++)
312 dest
[n
* dstride
] = 0 ;