]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/generated/maxloc0_4_i4.c
1 /* Implementation of the MAXLOC 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_INTEGER_4) && defined (HAVE_GFC_INTEGER_4)
35 extern void maxloc0_4_i4 (gfc_array_i4
* const restrict retarray
,
36 gfc_array_i4
* const restrict array
);
37 export_proto(maxloc0_4_i4
);
40 maxloc0_4_i4 (gfc_array_i4
* const restrict retarray
,
41 gfc_array_i4
* 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_INTEGER_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
))
68 index_type ret_extent
;
70 ret_rank
= GFC_DESCRIPTOR_RANK (retarray
);
72 runtime_error ("rank of return array in MAXLOC intrinsic"
73 " should be 1, is %ld", (long int) ret_rank
);
75 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,0);
76 if (ret_extent
!= rank
)
77 runtime_error ("Incorrect extent in return value of"
78 " MAXLOC intrnisic: is %ld, should be %ld",
79 (long int) ret_extent
, (long int) rank
);
83 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
84 dest
= retarray
->data
;
85 for (n
= 0; n
< rank
; n
++)
87 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
88 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
92 /* Set the return value. */
93 for (n
= 0; n
< rank
; n
++)
94 dest
[n
* dstride
] = 0;
101 /* Initialize the return value. */
102 for (n
= 0; n
< rank
; n
++)
103 dest
[n
* dstride
] = 0;
106 GFC_INTEGER_4 maxval
;
108 maxval
= (-GFC_INTEGER_4_HUGE
-1);
113 /* Implementation start. */
115 if (*base
> maxval
|| !dest
[0])
118 for (n
= 0; n
< rank
; n
++)
119 dest
[n
* dstride
] = count
[n
] + 1;
121 /* Implementation end. */
123 /* Advance to the next element. */
127 while (count
[n
] == extent
[n
])
129 /* When we get to the end of a dimension, reset it and increment
130 the next dimension. */
132 /* We could precalculate these products, but this is a less
133 frequently used path so probably not worth it. */
134 base
-= sstride
[n
] * extent
[n
];
138 /* Break out of the loop. */
153 extern void mmaxloc0_4_i4 (gfc_array_i4
* const restrict
,
154 gfc_array_i4
* const restrict
, gfc_array_l1
* const restrict
);
155 export_proto(mmaxloc0_4_i4
);
158 mmaxloc0_4_i4 (gfc_array_i4
* const restrict retarray
,
159 gfc_array_i4
* const restrict array
,
160 gfc_array_l1
* const restrict mask
)
162 index_type count
[GFC_MAX_DIMENSIONS
];
163 index_type extent
[GFC_MAX_DIMENSIONS
];
164 index_type sstride
[GFC_MAX_DIMENSIONS
];
165 index_type mstride
[GFC_MAX_DIMENSIONS
];
168 const GFC_INTEGER_4
*base
;
169 GFC_LOGICAL_1
*mbase
;
174 rank
= GFC_DESCRIPTOR_RANK (array
);
176 runtime_error ("Rank of array needs to be > 0");
178 if (retarray
->data
== NULL
)
180 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
- 1, 1);
181 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
182 retarray
->offset
= 0;
183 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_4
) * rank
);
187 if (unlikely (compile_options
.bounds_check
))
189 int ret_rank
, mask_rank
;
190 index_type ret_extent
;
192 index_type array_extent
, mask_extent
;
194 ret_rank
= GFC_DESCRIPTOR_RANK (retarray
);
196 runtime_error ("rank of return array in MAXLOC intrinsic"
197 " should be 1, is %ld", (long int) ret_rank
);
199 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,0);
200 if (ret_extent
!= rank
)
201 runtime_error ("Incorrect extent in return value of"
202 " MAXLOC intrnisic: is %ld, should be %ld",
203 (long int) ret_extent
, (long int) rank
);
205 mask_rank
= GFC_DESCRIPTOR_RANK (mask
);
206 if (rank
!= mask_rank
)
207 runtime_error ("rank of MASK argument in MAXLOC intrnisic"
208 "should be %ld, is %ld", (long int) rank
,
209 (long int) mask_rank
);
211 for (n
=0; n
<rank
; n
++)
213 array_extent
= GFC_DESCRIPTOR_EXTENT(array
,n
);
214 mask_extent
= GFC_DESCRIPTOR_EXTENT(mask
,n
);
215 if (array_extent
!= mask_extent
)
216 runtime_error ("Incorrect extent in MASK argument of"
217 " MAXLOC intrinsic in dimension %ld:"
218 " is %ld, should be %ld", (long int) n
+ 1,
219 (long int) mask_extent
, (long int) array_extent
);
224 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
228 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
229 #ifdef HAVE_GFC_LOGICAL_16
233 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
235 runtime_error ("Funny sized logical array");
237 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
238 dest
= retarray
->data
;
239 for (n
= 0; n
< rank
; n
++)
241 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
242 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
243 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
247 /* Set the return value. */
248 for (n
= 0; n
< rank
; n
++)
249 dest
[n
* dstride
] = 0;
256 /* Initialize the return value. */
257 for (n
= 0; n
< rank
; n
++)
258 dest
[n
* dstride
] = 0;
261 GFC_INTEGER_4 maxval
;
263 maxval
= (-GFC_INTEGER_4_HUGE
-1);
268 /* Implementation start. */
270 if (*mbase
&& (*base
> maxval
|| !dest
[0]))
273 for (n
= 0; n
< rank
; n
++)
274 dest
[n
* dstride
] = count
[n
] + 1;
276 /* Implementation end. */
278 /* Advance to the next element. */
283 while (count
[n
] == extent
[n
])
285 /* When we get to the end of a dimension, reset it and increment
286 the next dimension. */
288 /* We could precalculate these products, but this is a less
289 frequently used path so probably not worth it. */
290 base
-= sstride
[n
] * extent
[n
];
291 mbase
-= mstride
[n
] * extent
[n
];
295 /* Break out of the loop. */
311 extern void smaxloc0_4_i4 (gfc_array_i4
* const restrict
,
312 gfc_array_i4
* const restrict
, GFC_LOGICAL_4
*);
313 export_proto(smaxloc0_4_i4
);
316 smaxloc0_4_i4 (gfc_array_i4
* const restrict retarray
,
317 gfc_array_i4
* const restrict array
,
318 GFC_LOGICAL_4
* mask
)
327 maxloc0_4_i4 (retarray
, array
);
331 rank
= GFC_DESCRIPTOR_RANK (array
);
334 runtime_error ("Rank of array needs to be > 0");
336 if (retarray
->data
== NULL
)
338 GFC_DIMENSION_SET(retarray
->dim
[0], 0, rank
-1, 1);
339 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
340 retarray
->offset
= 0;
341 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_4
) * rank
);
345 if (unlikely (compile_options
.bounds_check
))
348 index_type ret_extent
;
350 ret_rank
= GFC_DESCRIPTOR_RANK (retarray
);
352 runtime_error ("rank of return array in MAXLOC intrinsic"
353 " should be 1, is %ld", (long int) ret_rank
);
355 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,0);
356 if (ret_extent
!= rank
)
357 runtime_error ("dimension of return array incorrect");
361 dstride
= GFC_DESCRIPTOR_STRIDE(retarray
,0);
362 dest
= retarray
->data
;
363 for (n
= 0; n
<rank
; n
++)
364 dest
[n
* dstride
] = 0 ;