]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/generated/minloc1_8_r4.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_4) && defined (HAVE_GFC_INTEGER_8)
40 extern void minloc1_8_r4 (gfc_array_i8
* const restrict
,
41 gfc_array_r4
* const restrict
, const index_type
* const restrict
);
42 export_proto(minloc1_8_r4
);
45 minloc1_8_r4 (gfc_array_i8
* const restrict retarray
,
46 gfc_array_r4
* 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_4
* restrict base
;
54 GFC_INTEGER_8
* 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_8
) * 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 %ld, should be %ld",
121 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
124 if (compile_options
.bounds_check
)
126 for (n
=0; n
< rank
; n
++)
128 index_type ret_extent
;
130 ret_extent
= retarray
->dim
[n
].ubound
+ 1
131 - retarray
->dim
[n
].lbound
;
132 if (extent
[n
] != ret_extent
)
133 runtime_error ("Incorrect extent in return value of"
134 " MINLOC intrinsic in dimension %ld:"
135 " is %ld, should be %ld", (long int) n
+ 1,
136 (long int) ret_extent
, (long int) extent
[n
]);
141 for (n
= 0; n
< rank
; n
++)
144 dstride
[n
] = retarray
->dim
[n
].stride
;
150 dest
= retarray
->data
;
154 const GFC_REAL_4
* restrict src
;
155 GFC_INTEGER_8 result
;
160 minval
= GFC_REAL_4_HUGE
;
166 for (n
= 0; n
< len
; n
++, src
+= delta
)
169 if (*src
< minval
|| !result
)
172 result
= (GFC_INTEGER_8
)n
+ 1;
178 /* Advance to the next element. */
183 while (count
[n
] == extent
[n
])
185 /* When we get to the end of a dimension, reset it and increment
186 the next dimension. */
188 /* We could precalculate these products, but this is a less
189 frequently used path so probably not worth it. */
190 base
-= sstride
[n
] * extent
[n
];
191 dest
-= dstride
[n
] * extent
[n
];
195 /* Break out of the look. */
210 extern void mminloc1_8_r4 (gfc_array_i8
* const restrict
,
211 gfc_array_r4
* const restrict
, const index_type
* const restrict
,
212 gfc_array_l1
* const restrict
);
213 export_proto(mminloc1_8_r4
);
216 mminloc1_8_r4 (gfc_array_i8
* const restrict retarray
,
217 gfc_array_r4
* const restrict array
,
218 const index_type
* const restrict pdim
,
219 gfc_array_l1
* const restrict mask
)
221 index_type count
[GFC_MAX_DIMENSIONS
];
222 index_type extent
[GFC_MAX_DIMENSIONS
];
223 index_type sstride
[GFC_MAX_DIMENSIONS
];
224 index_type dstride
[GFC_MAX_DIMENSIONS
];
225 index_type mstride
[GFC_MAX_DIMENSIONS
];
226 GFC_INTEGER_8
* restrict dest
;
227 const GFC_REAL_4
* restrict base
;
228 const GFC_LOGICAL_1
* restrict mbase
;
238 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
240 len
= array
->dim
[dim
].ubound
+ 1 - array
->dim
[dim
].lbound
;
246 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
248 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
249 #ifdef HAVE_GFC_LOGICAL_16
253 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
255 runtime_error ("Funny sized logical array");
257 delta
= array
->dim
[dim
].stride
;
258 mdelta
= mask
->dim
[dim
].stride
* mask_kind
;
260 for (n
= 0; n
< dim
; n
++)
262 sstride
[n
] = array
->dim
[n
].stride
;
263 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
264 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
270 for (n
= dim
; n
< rank
; n
++)
272 sstride
[n
] = array
->dim
[n
+ 1].stride
;
273 mstride
[n
] = mask
->dim
[n
+ 1].stride
* mask_kind
;
275 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
281 if (retarray
->data
== NULL
)
285 for (n
= 0; n
< rank
; n
++)
287 retarray
->dim
[n
].lbound
= 0;
288 retarray
->dim
[n
].ubound
= extent
[n
]-1;
290 retarray
->dim
[n
].stride
= 1;
292 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
295 alloc_size
= sizeof (GFC_INTEGER_8
) * retarray
->dim
[rank
-1].stride
298 retarray
->offset
= 0;
299 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
303 /* Make sure we have a zero-sized array. */
304 retarray
->dim
[0].lbound
= 0;
305 retarray
->dim
[0].ubound
= -1;
309 retarray
->data
= internal_malloc_size (alloc_size
);
314 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
315 runtime_error ("rank of return array incorrect in MINLOC intrinsic");
317 if (compile_options
.bounds_check
)
319 for (n
=0; n
< rank
; n
++)
321 index_type ret_extent
;
323 ret_extent
= retarray
->dim
[n
].ubound
+ 1
324 - retarray
->dim
[n
].lbound
;
325 if (extent
[n
] != ret_extent
)
326 runtime_error ("Incorrect extent in return value of"
327 " MINLOC intrinsic in dimension %ld:"
328 " is %ld, should be %ld", (long int) n
+ 1,
329 (long int) ret_extent
, (long int) extent
[n
]);
331 for (n
=0; n
<= rank
; n
++)
333 index_type mask_extent
, array_extent
;
335 array_extent
= array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
336 mask_extent
= mask
->dim
[n
].ubound
+ 1 - mask
->dim
[n
].lbound
;
337 if (array_extent
!= mask_extent
)
338 runtime_error ("Incorrect extent in MASK argument of"
339 " MINLOC intrinsic in dimension %ld:"
340 " is %ld, should be %ld", (long int) n
+ 1,
341 (long int) mask_extent
, (long int) array_extent
);
346 for (n
= 0; n
< rank
; n
++)
349 dstride
[n
] = retarray
->dim
[n
].stride
;
354 dest
= retarray
->data
;
359 const GFC_REAL_4
* restrict src
;
360 const GFC_LOGICAL_1
* restrict msrc
;
361 GFC_INTEGER_8 result
;
367 minval
= GFC_REAL_4_HUGE
;
373 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
376 if (*msrc
&& (*src
< minval
|| !result
))
379 result
= (GFC_INTEGER_8
)n
+ 1;
385 /* Advance to the next element. */
391 while (count
[n
] == extent
[n
])
393 /* When we get to the end of a dimension, reset it and increment
394 the next dimension. */
396 /* We could precalculate these products, but this is a less
397 frequently used path so probably not worth it. */
398 base
-= sstride
[n
] * extent
[n
];
399 mbase
-= mstride
[n
] * extent
[n
];
400 dest
-= dstride
[n
] * extent
[n
];
404 /* Break out of the look. */
420 extern void sminloc1_8_r4 (gfc_array_i8
* const restrict
,
421 gfc_array_r4
* const restrict
, const index_type
* const restrict
,
423 export_proto(sminloc1_8_r4
);
426 sminloc1_8_r4 (gfc_array_i8
* const restrict retarray
,
427 gfc_array_r4
* const restrict array
,
428 const index_type
* const restrict pdim
,
429 GFC_LOGICAL_4
* mask
)
431 index_type count
[GFC_MAX_DIMENSIONS
];
432 index_type extent
[GFC_MAX_DIMENSIONS
];
433 index_type sstride
[GFC_MAX_DIMENSIONS
];
434 index_type dstride
[GFC_MAX_DIMENSIONS
];
435 GFC_INTEGER_8
* restrict dest
;
443 minloc1_8_r4 (retarray
, array
, pdim
);
446 /* Make dim zero based to avoid confusion. */
448 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
450 for (n
= 0; n
< dim
; n
++)
452 sstride
[n
] = array
->dim
[n
].stride
;
453 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
459 for (n
= dim
; n
< rank
; n
++)
461 sstride
[n
] = array
->dim
[n
+ 1].stride
;
463 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
469 if (retarray
->data
== NULL
)
473 for (n
= 0; n
< rank
; n
++)
475 retarray
->dim
[n
].lbound
= 0;
476 retarray
->dim
[n
].ubound
= extent
[n
]-1;
478 retarray
->dim
[n
].stride
= 1;
480 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
483 retarray
->offset
= 0;
484 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
486 alloc_size
= sizeof (GFC_INTEGER_8
) * retarray
->dim
[rank
-1].stride
491 /* Make sure we have a zero-sized array. */
492 retarray
->dim
[0].lbound
= 0;
493 retarray
->dim
[0].ubound
= -1;
497 retarray
->data
= internal_malloc_size (alloc_size
);
501 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
502 runtime_error ("rank of return array incorrect in"
503 " MINLOC intrinsic: is %ld, should be %ld",
504 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
507 if (compile_options
.bounds_check
)
509 for (n
=0; n
< rank
; n
++)
511 index_type ret_extent
;
513 ret_extent
= retarray
->dim
[n
].ubound
+ 1
514 - retarray
->dim
[n
].lbound
;
515 if (extent
[n
] != ret_extent
)
516 runtime_error ("Incorrect extent in return value of"
517 " MINLOC intrinsic in dimension %ld:"
518 " is %ld, should be %ld", (long int) n
+ 1,
519 (long int) ret_extent
, (long int) extent
[n
]);
524 for (n
= 0; n
< rank
; n
++)
527 dstride
[n
] = retarray
->dim
[n
].stride
;
530 dest
= retarray
->data
;
538 while (count
[n
] == extent
[n
])
540 /* When we get to the end of a dimension, reset it and increment
541 the next dimension. */
543 /* We could precalculate these products, but this is a less
544 frequently used path so probably not worth it. */
545 dest
-= dstride
[n
] * extent
[n
];