]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/generated/minloc1_16_r16.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_REAL_16) && defined (HAVE_GFC_INTEGER_16)
40 extern void minloc1_16_r16 (gfc_array_i16
* const restrict
,
41 gfc_array_r16
* const restrict
, const index_type
* const restrict
);
42 export_proto(minloc1_16_r16
);
45 minloc1_16_r16 (gfc_array_i16
* const restrict retarray
,
46 gfc_array_r16
* const restrict array
,
47 const index_type
* const restrict pdim
)
49 index_type count
[GFC_MAX_DIMENSIONS
];
50 index_type extent
[GFC_MAX_DIMENSIONS
];
51 index_type sstride
[GFC_MAX_DIMENSIONS
];
52 index_type dstride
[GFC_MAX_DIMENSIONS
];
53 const GFC_REAL_16
* restrict base
;
54 GFC_INTEGER_16
* restrict dest
;
61 /* Make dim zero based to avoid confusion. */
63 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
65 len
= array
->dim
[dim
].ubound
+ 1 - array
->dim
[dim
].lbound
;
66 delta
= array
->dim
[dim
].stride
;
68 for (n
= 0; n
< dim
; n
++)
70 sstride
[n
] = array
->dim
[n
].stride
;
71 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
76 for (n
= dim
; n
< rank
; n
++)
78 sstride
[n
] = array
->dim
[n
+ 1].stride
;
80 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
86 if (retarray
->data
== NULL
)
90 for (n
= 0; n
< rank
; n
++)
92 retarray
->dim
[n
].lbound
= 0;
93 retarray
->dim
[n
].ubound
= extent
[n
]-1;
95 retarray
->dim
[n
].stride
= 1;
97 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
100 retarray
->offset
= 0;
101 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
103 alloc_size
= sizeof (GFC_INTEGER_16
) * retarray
->dim
[rank
-1].stride
108 /* Make sure we have a zero-sized array. */
109 retarray
->dim
[0].lbound
= 0;
110 retarray
->dim
[0].ubound
= -1;
114 retarray
->data
= internal_malloc_size (alloc_size
);
118 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
119 runtime_error ("rank of return array incorrect in"
120 " MINLOC intrinsic: is %d, should be %d",
121 GFC_DESCRIPTOR_RANK (retarray
), rank
);
123 if (compile_options
.bounds_check
)
125 for (n
=0; n
< rank
; n
++)
127 index_type ret_extent
;
129 ret_extent
= retarray
->dim
[n
].ubound
+ 1
130 - retarray
->dim
[n
].lbound
;
131 if (extent
[n
] != ret_extent
)
132 runtime_error ("Incorrect extent in return value of"
133 " MINLOC intrinsic in dimension %d:"
134 " is %ld, should be %ld", n
+ 1,
135 (long int) ret_extent
, (long int) extent
[n
]);
140 for (n
= 0; n
< rank
; n
++)
143 dstride
[n
] = retarray
->dim
[n
].stride
;
149 dest
= retarray
->data
;
153 const GFC_REAL_16
* restrict src
;
154 GFC_INTEGER_16 result
;
159 minval
= GFC_REAL_16_HUGE
;
165 for (n
= 0; n
< len
; n
++, src
+= delta
)
168 if (*src
< minval
|| !result
)
171 result
= (GFC_INTEGER_16
)n
+ 1;
177 /* Advance to the next element. */
182 while (count
[n
] == extent
[n
])
184 /* When we get to the end of a dimension, reset it and increment
185 the next dimension. */
187 /* We could precalculate these products, but this is a less
188 frequently used path so probably not worth it. */
189 base
-= sstride
[n
] * extent
[n
];
190 dest
-= dstride
[n
] * extent
[n
];
194 /* Break out of the look. */
209 extern void mminloc1_16_r16 (gfc_array_i16
* const restrict
,
210 gfc_array_r16
* const restrict
, const index_type
* const restrict
,
211 gfc_array_l1
* const restrict
);
212 export_proto(mminloc1_16_r16
);
215 mminloc1_16_r16 (gfc_array_i16
* const restrict retarray
,
216 gfc_array_r16
* const restrict array
,
217 const index_type
* const restrict pdim
,
218 gfc_array_l1
* const restrict mask
)
220 index_type count
[GFC_MAX_DIMENSIONS
];
221 index_type extent
[GFC_MAX_DIMENSIONS
];
222 index_type sstride
[GFC_MAX_DIMENSIONS
];
223 index_type dstride
[GFC_MAX_DIMENSIONS
];
224 index_type mstride
[GFC_MAX_DIMENSIONS
];
225 GFC_INTEGER_16
* restrict dest
;
226 const GFC_REAL_16
* restrict base
;
227 const GFC_LOGICAL_1
* restrict mbase
;
237 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
239 len
= array
->dim
[dim
].ubound
+ 1 - array
->dim
[dim
].lbound
;
245 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
247 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
248 #ifdef HAVE_GFC_LOGICAL_16
252 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
254 runtime_error ("Funny sized logical array");
256 delta
= array
->dim
[dim
].stride
;
257 mdelta
= mask
->dim
[dim
].stride
* mask_kind
;
259 for (n
= 0; n
< dim
; n
++)
261 sstride
[n
] = array
->dim
[n
].stride
;
262 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
263 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
269 for (n
= dim
; n
< rank
; n
++)
271 sstride
[n
] = array
->dim
[n
+ 1].stride
;
272 mstride
[n
] = mask
->dim
[n
+ 1].stride
* mask_kind
;
274 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
280 if (retarray
->data
== NULL
)
284 for (n
= 0; n
< rank
; n
++)
286 retarray
->dim
[n
].lbound
= 0;
287 retarray
->dim
[n
].ubound
= extent
[n
]-1;
289 retarray
->dim
[n
].stride
= 1;
291 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
294 alloc_size
= sizeof (GFC_INTEGER_16
) * retarray
->dim
[rank
-1].stride
297 retarray
->offset
= 0;
298 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
302 /* Make sure we have a zero-sized array. */
303 retarray
->dim
[0].lbound
= 0;
304 retarray
->dim
[0].ubound
= -1;
308 retarray
->data
= internal_malloc_size (alloc_size
);
313 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
314 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
316 if (compile_options
.bounds_check
)
318 for (n
=0; n
< rank
; n
++)
320 index_type ret_extent
;
322 ret_extent
= retarray
->dim
[n
].ubound
+ 1
323 - retarray
->dim
[n
].lbound
;
324 if (extent
[n
] != ret_extent
)
325 runtime_error ("Incorrect extent in return value of"
326 " MINLOC intrinsic in dimension %d:"
327 " is %ld, should be %ld", n
+ 1,
328 (long int) ret_extent
, (long int) extent
[n
]);
330 for (n
=0; n
<= rank
; n
++)
332 index_type mask_extent
, array_extent
;
334 array_extent
= array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
335 mask_extent
= mask
->dim
[n
].ubound
+ 1 - mask
->dim
[n
].lbound
;
336 if (array_extent
!= mask_extent
)
337 runtime_error ("Incorrect extent in MASK argument of"
338 " MINLOC intrinsic in dimension %d:"
339 " is %ld, should be %ld", n
+ 1,
340 (long int) mask_extent
, (long int) array_extent
);
345 for (n
= 0; n
< rank
; n
++)
348 dstride
[n
] = retarray
->dim
[n
].stride
;
353 dest
= retarray
->data
;
358 const GFC_REAL_16
* restrict src
;
359 const GFC_LOGICAL_1
* restrict msrc
;
360 GFC_INTEGER_16 result
;
366 minval
= GFC_REAL_16_HUGE
;
372 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
375 if (*msrc
&& (*src
< minval
|| !result
))
378 result
= (GFC_INTEGER_16
)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 look. */
419 extern void sminloc1_16_r16 (gfc_array_i16
* const restrict
,
420 gfc_array_r16
* const restrict
, const index_type
* const restrict
,
422 export_proto(sminloc1_16_r16
);
425 sminloc1_16_r16 (gfc_array_i16
* const restrict retarray
,
426 gfc_array_r16
* const restrict array
,
427 const index_type
* const restrict pdim
,
428 GFC_LOGICAL_4
* mask
)
433 GFC_INTEGER_16
*dest
;
437 minloc1_16_r16 (retarray
, array
, pdim
);
440 rank
= GFC_DESCRIPTOR_RANK (array
);
442 runtime_error ("Rank of array needs to be > 0");
444 if (retarray
->data
== NULL
)
446 retarray
->dim
[0].lbound
= 0;
447 retarray
->dim
[0].ubound
= rank
-1;
448 retarray
->dim
[0].stride
= 1;
449 retarray
->dtype
= (retarray
->dtype
& ~GFC_DTYPE_RANK_MASK
) | 1;
450 retarray
->offset
= 0;
451 retarray
->data
= internal_malloc_size (sizeof (GFC_INTEGER_16
) * rank
);
455 if (compile_options
.bounds_check
)
458 index_type ret_extent
;
460 ret_rank
= GFC_DESCRIPTOR_RANK (retarray
);
462 runtime_error ("rank of return array in MINLOC intrinsic"
463 " should be 1, is %d", ret_rank
);
465 ret_extent
= retarray
->dim
[0].ubound
+ 1 - retarray
->dim
[0].lbound
;
466 if (ret_extent
!= rank
)
467 runtime_error ("dimension of return array incorrect");
470 dstride
= retarray
->dim
[0].stride
;
471 dest
= retarray
->data
;
473 for (n
= 0; n
< rank
; n
++)
474 dest
[n
* dstride
] = 0 ;