]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/generated/minloc0_4_i8.c
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_8) && defined (HAVE_GFC_INTEGER_4)
40 extern void minloc0_4_i8 (gfc_array_i4
* const restrict retarray
,
41 gfc_array_i8
* const restrict array
);
42 export_proto(minloc0_4_i8
);
45 minloc0_4_i8 (gfc_array_i4
* const restrict retarray
,
46 gfc_array_i8
* 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_8
*base
;
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_4
) * rank
);
72 if (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 %d", 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 %d",
86 (long int) ret_extent
, 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_8 minval
;
115 minval
= GFC_INTEGER_8_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_4_i8 (gfc_array_i4
* const restrict
,
161 gfc_array_i8
* const restrict
, gfc_array_l1
* const restrict
);
162 export_proto(mminloc0_4_i8
);
165 mminloc0_4_i8 (gfc_array_i4
* const restrict retarray
,
166 gfc_array_i8
* 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_8
*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_4
) * rank
);
196 if (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 %d", 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 %d",
212 (long int) ret_extent
, 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 %d, is %d", rank
, mask_rank
);
219 for (n
=0; n
<rank
; n
++)
221 array_extent
= array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
222 mask_extent
= mask
->dim
[n
].ubound
+ 1 - mask
->dim
[n
].lbound
;
223 if (array_extent
!= mask_extent
)
224 runtime_error ("Incorrect extent in MASK argument of"
225 " MINLOC intrinsic in dimension %d:"
226 " is %ld, should be %ld", n
+ 1,
227 (long int) mask_extent
, (long int) array_extent
);
232 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
236 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
237 #ifdef HAVE_GFC_LOGICAL_16
241 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
243 runtime_error ("Funny sized logical array");
245 dstride
= retarray
->dim
[0].stride
;
246 dest
= retarray
->data
;
247 for (n
= 0; n
< rank
; n
++)
249 sstride
[n
] = array
->dim
[n
].stride
;
250 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
251 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
255 /* Set the return value. */
256 for (n
= 0; n
< rank
; n
++)
257 dest
[n
* dstride
] = 0;
264 /* Initialize the return value. */
265 for (n
= 0; n
< rank
; n
++)
266 dest
[n
* dstride
] = 0;
269 GFC_INTEGER_8 minval
;
271 minval
= GFC_INTEGER_8_HUGE
;
276 /* Implementation start. */
278 if (*mbase
&& (*base
< minval
|| !dest
[0]))
281 for (n
= 0; n
< rank
; n
++)
282 dest
[n
* dstride
] = count
[n
] + 1;
284 /* Implementation end. */
286 /* Advance to the next element. */
291 while (count
[n
] == extent
[n
])
293 /* When we get to the end of a dimension, reset it and increment
294 the next dimension. */
296 /* We could precalculate these products, but this is a less
297 frequently used path so probably not worth it. */
298 base
-= sstride
[n
] * extent
[n
];
299 mbase
-= mstride
[n
] * extent
[n
];
303 /* Break out of the loop. */
319 extern void sminloc0_4_i8 (gfc_array_i4
* const restrict
,
320 gfc_array_i8
* const restrict
, GFC_LOGICAL_4
*);
321 export_proto(sminloc0_4_i8
);
324 sminloc0_4_i8 (gfc_array_i4
* const restrict retarray
,
325 gfc_array_i8
* const restrict array
,
326 GFC_LOGICAL_4
* mask
)
335 minloc0_4_i8 (retarray
, array
);
339 rank
= GFC_DESCRIPTOR_RANK (array
);
342 runtime_error ("Rank of array needs to be > 0");
344 if (retarray
->data
== NULL
)
346 retarray
->dim
[0].lbound
= 0;
347 retarray
->dim
[0].ubound
= rank
-1;
348 retarray
->dim
[0].stride
= 1;
349 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
350 retarray
->offset
= 0;
351 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_4
) * rank
);
355 if (compile_options
.bounds_check
)
358 index_type ret_extent
;
360 ret_rank
= GFC_DESCRIPTOR_RANK (retarray
);
362 runtime_error ("rank of return array in MINLOC intrinsic"
363 " should be 1, is %d", ret_rank
);
365 ret_extent
= retarray
->dim
[0].ubound
+ 1 - retarray
->dim
[0].lbound
;
366 if (ret_extent
!= rank
)
367 runtime_error ("dimension of return array incorrect");
371 dstride
= retarray
->dim
[0].stride
;
372 dest
= retarray
->data
;
373 for (n
= 0; n
<rank
; n
++)
374 dest
[n
* dstride
] = 0 ;