1 /* Implementation of the MINLOC intrinsic
2 Copyright 2002 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., 59 Temple Place - Suite 330,
29 Boston, MA 02111-1307, USA. */
36 #include "libgfortran.h"
39 extern void minloc1_8_r8 (gfc_array_i8
*, gfc_array_r8
*, index_type
*);
40 export_proto(minloc1_8_r8
);
43 minloc1_8_r8 (gfc_array_i8
*retarray
, gfc_array_r8
*array
, index_type
*pdim
)
45 index_type count
[GFC_MAX_DIMENSIONS
- 1];
46 index_type extent
[GFC_MAX_DIMENSIONS
- 1];
47 index_type sstride
[GFC_MAX_DIMENSIONS
- 1];
48 index_type dstride
[GFC_MAX_DIMENSIONS
- 1];
57 /* Make dim zero based to avoid confusion. */
59 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
60 if (array
->dim
[0].stride
== 0)
61 array
->dim
[0].stride
= 1;
63 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
;
71 for (n
= dim
; n
< rank
; n
++)
73 sstride
[n
] = array
->dim
[n
+ 1].stride
;
75 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
78 if (retarray
->data
== NULL
)
80 for (n
= 0; n
< rank
; n
++)
82 retarray
->dim
[n
].lbound
= 0;
83 retarray
->dim
[n
].ubound
= extent
[n
]-1;
85 retarray
->dim
[n
].stride
= 1;
87 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
91 = internal_malloc_size (sizeof (GFC_INTEGER_8
)
92 * retarray
->dim
[rank
-1].stride
95 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
99 if (retarray
->dim
[0].stride
== 0)
100 retarray
->dim
[0].stride
= 1;
102 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
103 runtime_error ("rank of return array incorrect");
106 for (n
= 0; n
< rank
; n
++)
109 dstride
[n
] = retarray
->dim
[n
].stride
;
115 dest
= retarray
->data
;
120 GFC_INTEGER_8 result
;
125 minval
= GFC_REAL_8_HUGE
;
131 for (n
= 0; n
< len
; n
++, src
+= delta
)
137 result
= (GFC_INTEGER_8
)n
+ 1;
143 /* Advance to the next element. */
148 while (count
[n
] == extent
[n
])
150 /* When we get to the end of a dimension, reset it and increment
151 the next dimension. */
153 /* We could precalculate these products, but this is a less
154 frequently used path so proabably not worth it. */
155 base
-= sstride
[n
] * extent
[n
];
156 dest
-= dstride
[n
] * extent
[n
];
160 /* Break out of the look. */
175 extern void mminloc1_8_r8 (gfc_array_i8
*, gfc_array_r8
*, index_type
*,
177 export_proto(mminloc1_8_r8
);
180 mminloc1_8_r8 (gfc_array_i8
* retarray
, gfc_array_r8
* array
,
181 index_type
*pdim
, gfc_array_l4
* mask
)
183 index_type count
[GFC_MAX_DIMENSIONS
- 1];
184 index_type extent
[GFC_MAX_DIMENSIONS
- 1];
185 index_type sstride
[GFC_MAX_DIMENSIONS
- 1];
186 index_type dstride
[GFC_MAX_DIMENSIONS
- 1];
187 index_type mstride
[GFC_MAX_DIMENSIONS
- 1];
190 GFC_LOGICAL_4
*mbase
;
199 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
200 if (array
->dim
[0].stride
== 0)
201 array
->dim
[0].stride
= 1;
203 len
= array
->dim
[dim
].ubound
+ 1 - array
->dim
[dim
].lbound
;
206 delta
= array
->dim
[dim
].stride
;
207 mdelta
= mask
->dim
[dim
].stride
;
209 for (n
= 0; n
< dim
; n
++)
211 sstride
[n
] = array
->dim
[n
].stride
;
212 mstride
[n
] = mask
->dim
[n
].stride
;
213 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
215 for (n
= dim
; n
< rank
; n
++)
217 sstride
[n
] = array
->dim
[n
+ 1].stride
;
218 mstride
[n
] = mask
->dim
[n
+ 1].stride
;
220 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
223 if (retarray
->data
== NULL
)
225 for (n
= 0; n
< rank
; n
++)
227 retarray
->dim
[n
].lbound
= 0;
228 retarray
->dim
[n
].ubound
= extent
[n
]-1;
230 retarray
->dim
[n
].stride
= 1;
232 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
236 = internal_malloc_size (sizeof (GFC_INTEGER_8
)
237 * retarray
->dim
[rank
-1].stride
240 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
244 if (retarray
->dim
[0].stride
== 0)
245 retarray
->dim
[0].stride
= 1;
247 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
248 runtime_error ("rank of return array incorrect");
251 for (n
= 0; n
< rank
; n
++)
254 dstride
[n
] = retarray
->dim
[n
].stride
;
259 dest
= retarray
->data
;
263 if (GFC_DESCRIPTOR_SIZE (mask
) != 4)
265 /* This allows the same loop to be used for all logical types. */
266 assert (GFC_DESCRIPTOR_SIZE (mask
) == 8);
267 for (n
= 0; n
< rank
; n
++)
270 mbase
= (GFOR_POINTER_L8_TO_L4 (mbase
));
277 GFC_INTEGER_8 result
;
283 minval
= GFC_REAL_8_HUGE
;
289 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
292 if (*msrc
&& *src
< minval
)
295 result
= (GFC_INTEGER_8
)n
+ 1;
301 /* Advance to the next element. */
307 while (count
[n
] == extent
[n
])
309 /* When we get to the end of a dimension, reset it and increment
310 the next dimension. */
312 /* We could precalculate these products, but this is a less
313 frequently used path so proabably not worth it. */
314 base
-= sstride
[n
] * extent
[n
];
315 mbase
-= mstride
[n
] * extent
[n
];
316 dest
-= dstride
[n
] * extent
[n
];
320 /* Break out of the look. */