1 /* Implementation of the MINLOC 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"
37 #if defined (HAVE_GFC_INTEGER_2) && defined (HAVE_GFC_INTEGER_8)
40 extern void minloc0_8_i2 (gfc_array_i8
* const restrict retarray
,
41 gfc_array_i2
* const restrict array
);
42 export_proto(minloc0_8_i2
);
45 minloc0_8_i2 (gfc_array_i8
* const restrict retarray
,
46 gfc_array_i2
* const restrict array
)
48 index_type count
[GFC_MAX_DIMENSIONS
];
49 index_type extent
[GFC_MAX_DIMENSIONS
];
50 index_type sstride
[GFC_MAX_DIMENSIONS
];
52 const GFC_INTEGER_2
*base
;
53 GFC_INTEGER_8
* restrict dest
;
57 rank
= GFC_DESCRIPTOR_RANK (array
);
59 runtime_error ("Rank of array needs to be > 0");
61 if (retarray
->data
== NULL
)
63 retarray
->dim
[0].lbound
= 0;
64 retarray
->dim
[0].ubound
= rank
-1;
65 retarray
->dim
[0].stride
= 1;
66 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
68 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_8
) * rank
);
72 if (unlikely (compile_options
.bounds_check
))
75 index_type ret_extent
;
77 ret_rank
= GFC_DESCRIPTOR_RANK (retarray
);
79 runtime_error ("rank of return array in MINLOC intrinsic"
80 " should be 1, is %ld", (long int) ret_rank
);
82 ret_extent
= retarray
->dim
[0].ubound
+ 1 - retarray
->dim
[0].lbound
;
83 if (ret_extent
!= rank
)
84 runtime_error ("Incorrect extent in return value of"
85 " MINLOC intrnisic: is %ld, should be %ld",
86 (long int) ret_extent
, (long int) rank
);
90 dstride
= retarray
->dim
[0].stride
;
91 dest
= retarray
->data
;
92 for (n
= 0; n
< rank
; n
++)
94 sstride
[n
] = array
->dim
[n
].stride
;
95 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
99 /* Set the return value. */
100 for (n
= 0; n
< rank
; n
++)
101 dest
[n
* dstride
] = 0;
108 /* Initialize the return value. */
109 for (n
= 0; n
< rank
; n
++)
110 dest
[n
* dstride
] = 0;
113 GFC_INTEGER_2 minval
;
115 minval
= GFC_INTEGER_2_HUGE
;
120 /* Implementation start. */
122 if (*base
< minval
|| !dest
[0])
125 for (n
= 0; n
< rank
; n
++)
126 dest
[n
* dstride
] = count
[n
] + 1;
128 /* Implementation end. */
130 /* Advance to the next element. */
134 while (count
[n
] == extent
[n
])
136 /* When we get to the end of a dimension, reset it and increment
137 the next dimension. */
139 /* We could precalculate these products, but this is a less
140 frequently used path so probably not worth it. */
141 base
-= sstride
[n
] * extent
[n
];
145 /* Break out of the loop. */
160 extern void mminloc0_8_i2 (gfc_array_i8
* const restrict
,
161 gfc_array_i2
* const restrict
, gfc_array_l1
* const restrict
);
162 export_proto(mminloc0_8_i2
);
165 mminloc0_8_i2 (gfc_array_i8
* const restrict retarray
,
166 gfc_array_i2
* const restrict array
,
167 gfc_array_l1
* const restrict mask
)
169 index_type count
[GFC_MAX_DIMENSIONS
];
170 index_type extent
[GFC_MAX_DIMENSIONS
];
171 index_type sstride
[GFC_MAX_DIMENSIONS
];
172 index_type mstride
[GFC_MAX_DIMENSIONS
];
175 const GFC_INTEGER_2
*base
;
176 GFC_LOGICAL_1
*mbase
;
181 rank
= GFC_DESCRIPTOR_RANK (array
);
183 runtime_error ("Rank of array needs to be > 0");
185 if (retarray
->data
== NULL
)
187 retarray
->dim
[0].lbound
= 0;
188 retarray
->dim
[0].ubound
= rank
-1;
189 retarray
->dim
[0].stride
= 1;
190 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
191 retarray
->offset
= 0;
192 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_8
) * rank
);
196 if (unlikely (compile_options
.bounds_check
))
198 int ret_rank
, mask_rank
;
199 index_type ret_extent
;
201 index_type array_extent
, mask_extent
;
203 ret_rank
= GFC_DESCRIPTOR_RANK (retarray
);
205 runtime_error ("rank of return array in MINLOC intrinsic"
206 " should be 1, is %ld", (long int) ret_rank
);
208 ret_extent
= retarray
->dim
[0].ubound
+ 1 - retarray
->dim
[0].lbound
;
209 if (ret_extent
!= rank
)
210 runtime_error ("Incorrect extent in return value of"
211 " MINLOC intrnisic: is %ld, should be %ld",
212 (long int) ret_extent
, (long int) rank
);
214 mask_rank
= GFC_DESCRIPTOR_RANK (mask
);
215 if (rank
!= mask_rank
)
216 runtime_error ("rank of MASK argument in MINLOC intrnisic"
217 "should be %ld, is %ld", (long int) rank
,
218 (long int) mask_rank
);
220 for (n
=0; n
<rank
; n
++)
222 array_extent
= array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
223 mask_extent
= mask
->dim
[n
].ubound
+ 1 - mask
->dim
[n
].lbound
;
224 if (array_extent
!= mask_extent
)
225 runtime_error ("Incorrect extent in MASK argument of"
226 " MINLOC intrinsic in dimension %ld:"
227 " is %ld, should be %ld", (long int) n
+ 1,
228 (long int) mask_extent
, (long int) array_extent
);
233 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
237 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
238 #ifdef HAVE_GFC_LOGICAL_16
242 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
244 runtime_error ("Funny sized logical array");
246 dstride
= retarray
->dim
[0].stride
;
247 dest
= retarray
->data
;
248 for (n
= 0; n
< rank
; n
++)
250 sstride
[n
] = array
->dim
[n
].stride
;
251 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
252 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
256 /* Set the return value. */
257 for (n
= 0; n
< rank
; n
++)
258 dest
[n
* dstride
] = 0;
265 /* Initialize the return value. */
266 for (n
= 0; n
< rank
; n
++)
267 dest
[n
* dstride
] = 0;
270 GFC_INTEGER_2 minval
;
272 minval
= GFC_INTEGER_2_HUGE
;
277 /* Implementation start. */
279 if (*mbase
&& (*base
< minval
|| !dest
[0]))
282 for (n
= 0; n
< rank
; n
++)
283 dest
[n
* dstride
] = count
[n
] + 1;
285 /* Implementation end. */
287 /* Advance to the next element. */
292 while (count
[n
] == extent
[n
])
294 /* When we get to the end of a dimension, reset it and increment
295 the next dimension. */
297 /* We could precalculate these products, but this is a less
298 frequently used path so probably not worth it. */
299 base
-= sstride
[n
] * extent
[n
];
300 mbase
-= mstride
[n
] * extent
[n
];
304 /* Break out of the loop. */
320 extern void sminloc0_8_i2 (gfc_array_i8
* const restrict
,
321 gfc_array_i2
* const restrict
, GFC_LOGICAL_4
*);
322 export_proto(sminloc0_8_i2
);
325 sminloc0_8_i2 (gfc_array_i8
* const restrict retarray
,
326 gfc_array_i2
* const restrict array
,
327 GFC_LOGICAL_4
* mask
)
336 minloc0_8_i2 (retarray
, array
);
340 rank
= GFC_DESCRIPTOR_RANK (array
);
343 runtime_error ("Rank of array needs to be > 0");
345 if (retarray
->data
== NULL
)
347 retarray
->dim
[0].lbound
= 0;
348 retarray
->dim
[0].ubound
= rank
-1;
349 retarray
->dim
[0].stride
= 1;
350 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
351 retarray
->offset
= 0;
352 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_8
) * rank
);
356 if (unlikely (compile_options
.bounds_check
))
359 index_type ret_extent
;
361 ret_rank
= GFC_DESCRIPTOR_RANK (retarray
);
363 runtime_error ("rank of return array in MINLOC intrinsic"
364 " should be 1, is %ld", (long int) ret_rank
);
366 ret_extent
= retarray
->dim
[0].ubound
+ 1 - retarray
->dim
[0].lbound
;
367 if (ret_extent
!= rank
)
368 runtime_error ("dimension of return array incorrect");
372 dstride
= retarray
->dim
[0].stride
;
373 dest
= retarray
->data
;
374 for (n
= 0; n
<rank
; n
++)
375 dest
[n
* dstride
] = 0 ;