]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/generated/minloc1_4_r4.c
1 /* Implementation of the MINLOC 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_REAL_4) && defined (HAVE_GFC_INTEGER_4)
35 extern void minloc1_4_r4 (gfc_array_i4
* const restrict
,
36 gfc_array_r4
* const restrict
, const index_type
* const restrict
);
37 export_proto(minloc1_4_r4
);
40 minloc1_4_r4 (gfc_array_i4
* const restrict retarray
,
41 gfc_array_r4
* const restrict array
,
42 const index_type
* const restrict pdim
)
44 index_type count
[GFC_MAX_DIMENSIONS
];
45 index_type extent
[GFC_MAX_DIMENSIONS
];
46 index_type sstride
[GFC_MAX_DIMENSIONS
];
47 index_type dstride
[GFC_MAX_DIMENSIONS
];
48 const GFC_REAL_4
* restrict base
;
49 GFC_INTEGER_4
* restrict dest
;
57 /* Make dim zero based to avoid confusion. */
59 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
61 len
= array
->dim
[dim
].ubound
+ 1 - array
->dim
[dim
].lbound
;
64 delta
= array
->dim
[dim
].stride
;
66 for (n
= 0; n
< dim
; n
++)
68 sstride
[n
] = array
->dim
[n
].stride
;
69 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
74 for (n
= dim
; n
< rank
; n
++)
76 sstride
[n
] = array
->dim
[n
+ 1].stride
;
78 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
84 if (retarray
->data
== NULL
)
88 for (n
= 0; n
< rank
; n
++)
90 retarray
->dim
[n
].lbound
= 0;
91 retarray
->dim
[n
].ubound
= extent
[n
]-1;
93 retarray
->dim
[n
].stride
= 1;
95 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
99 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
101 alloc_size
= sizeof (GFC_INTEGER_4
) * retarray
->dim
[rank
-1].stride
106 /* Make sure we have a zero-sized array. */
107 retarray
->dim
[0].lbound
= 0;
108 retarray
->dim
[0].ubound
= -1;
112 retarray
->data
= internal_malloc_size (alloc_size
);
116 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
117 runtime_error ("rank of return array incorrect in"
118 " MINLOC intrinsic: is %ld, should be %ld",
119 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
122 if (unlikely (compile_options
.bounds_check
))
124 for (n
=0; n
< rank
; n
++)
126 index_type ret_extent
;
128 ret_extent
= retarray
->dim
[n
].ubound
+ 1
129 - retarray
->dim
[n
].lbound
;
130 if (extent
[n
] != ret_extent
)
131 runtime_error ("Incorrect extent in return value of"
132 " MINLOC intrinsic in dimension %ld:"
133 " is %ld, should be %ld", (long int) n
+ 1,
134 (long int) ret_extent
, (long int) extent
[n
]);
139 for (n
= 0; n
< rank
; n
++)
142 dstride
[n
] = retarray
->dim
[n
].stride
;
148 dest
= retarray
->data
;
151 while (continue_loop
)
153 const GFC_REAL_4
* restrict src
;
154 GFC_INTEGER_4 result
;
159 minval
= GFC_REAL_4_HUGE
;
165 for (n
= 0; n
< len
; n
++, src
+= delta
)
168 if (*src
< minval
|| !result
)
171 result
= (GFC_INTEGER_4
)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_4_r4 (gfc_array_i4
* const restrict
,
210 gfc_array_r4
* const restrict
, const index_type
* const restrict
,
211 gfc_array_l1
* const restrict
);
212 export_proto(mminloc1_4_r4
);
215 mminloc1_4_r4 (gfc_array_i4
* const restrict retarray
,
216 gfc_array_r4
* 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_4
* restrict dest
;
226 const GFC_REAL_4
* 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_4
) * 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 (unlikely (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 %ld:"
327 " is %ld, should be %ld", (long int) 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 %ld:"
339 " is %ld, should be %ld", (long int) 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_4
* restrict src
;
359 const GFC_LOGICAL_1
* restrict msrc
;
360 GFC_INTEGER_4 result
;
366 minval
= GFC_REAL_4_HUGE
;
372 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
375 if (*msrc
&& (*src
< minval
|| !result
))
378 result
= (GFC_INTEGER_4
)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_4_r4 (gfc_array_i4
* const restrict
,
420 gfc_array_r4
* const restrict
, const index_type
* const restrict
,
422 export_proto(sminloc1_4_r4
);
425 sminloc1_4_r4 (gfc_array_i4
* const restrict retarray
,
426 gfc_array_r4
* const restrict array
,
427 const index_type
* const restrict pdim
,
428 GFC_LOGICAL_4
* mask
)
430 index_type count
[GFC_MAX_DIMENSIONS
];
431 index_type extent
[GFC_MAX_DIMENSIONS
];
432 index_type sstride
[GFC_MAX_DIMENSIONS
];
433 index_type dstride
[GFC_MAX_DIMENSIONS
];
434 GFC_INTEGER_4
* restrict dest
;
442 minloc1_4_r4 (retarray
, array
, pdim
);
445 /* Make dim zero based to avoid confusion. */
447 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
449 for (n
= 0; n
< dim
; n
++)
451 sstride
[n
] = array
->dim
[n
].stride
;
452 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
458 for (n
= dim
; n
< rank
; n
++)
460 sstride
[n
] = array
->dim
[n
+ 1].stride
;
462 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
468 if (retarray
->data
== NULL
)
472 for (n
= 0; n
< rank
; n
++)
474 retarray
->dim
[n
].lbound
= 0;
475 retarray
->dim
[n
].ubound
= extent
[n
]-1;
477 retarray
->dim
[n
].stride
= 1;
479 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
482 retarray
->offset
= 0;
483 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
485 alloc_size
= sizeof (GFC_INTEGER_4
) * retarray
->dim
[rank
-1].stride
490 /* Make sure we have a zero-sized array. */
491 retarray
->dim
[0].lbound
= 0;
492 retarray
->dim
[0].ubound
= -1;
496 retarray
->data
= internal_malloc_size (alloc_size
);
500 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
501 runtime_error ("rank of return array incorrect in"
502 " MINLOC intrinsic: is %ld, should be %ld",
503 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
506 if (unlikely (compile_options
.bounds_check
))
508 for (n
=0; n
< rank
; n
++)
510 index_type ret_extent
;
512 ret_extent
= retarray
->dim
[n
].ubound
+ 1
513 - retarray
->dim
[n
].lbound
;
514 if (extent
[n
] != ret_extent
)
515 runtime_error ("Incorrect extent in return value of"
516 " MINLOC intrinsic in dimension %ld:"
517 " is %ld, should be %ld", (long int) n
+ 1,
518 (long int) ret_extent
, (long int) extent
[n
]);
523 for (n
= 0; n
< rank
; n
++)
526 dstride
[n
] = retarray
->dim
[n
].stride
;
529 dest
= retarray
->data
;
537 while (count
[n
] == extent
[n
])
539 /* When we get to the end of a dimension, reset it and increment
540 the next dimension. */
542 /* We could precalculate these products, but this is a less
543 frequently used path so probably not worth it. */
544 dest
-= dstride
[n
] * extent
[n
];