]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/generated/sum_r4.c
1 /* Implementation of the SUM intrinsic
2 Copyright (C) 2002-2016 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"
30 #if defined (HAVE_GFC_REAL_4) && defined (HAVE_GFC_REAL_4)
33 extern void sum_r4 (gfc_array_r4
* const restrict
,
34 gfc_array_r4
* const restrict
, const index_type
* const restrict
);
38 sum_r4 (gfc_array_r4
* const restrict retarray
,
39 gfc_array_r4
* const restrict array
,
40 const index_type
* const restrict pdim
)
42 index_type count
[GFC_MAX_DIMENSIONS
];
43 index_type extent
[GFC_MAX_DIMENSIONS
];
44 index_type sstride
[GFC_MAX_DIMENSIONS
];
45 index_type dstride
[GFC_MAX_DIMENSIONS
];
46 const GFC_REAL_4
* restrict base
;
47 GFC_REAL_4
* restrict dest
;
55 /* Make dim zero based to avoid confusion. */
57 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
59 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
62 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
64 for (n
= 0; n
< dim
; n
++)
66 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
67 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
72 for (n
= dim
; n
< rank
; n
++)
74 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
75 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
81 if (retarray
->base_addr
== NULL
)
83 size_t alloc_size
, str
;
85 for (n
= 0; n
< rank
; n
++)
90 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
92 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
97 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
99 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
101 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_REAL_4
));
104 /* Make sure we have a zero-sized array. */
105 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
112 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
113 runtime_error ("rank of return array incorrect in"
114 " SUM intrinsic: is %ld, should be %ld",
115 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
118 if (unlikely (compile_options
.bounds_check
))
119 bounds_ifunction_return ((array_t
*) retarray
, extent
,
120 "return value", "SUM");
123 for (n
= 0; n
< rank
; n
++)
126 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
131 base
= array
->base_addr
;
132 dest
= retarray
->base_addr
;
135 while (continue_loop
)
137 const GFC_REAL_4
* restrict src
;
147 for (n
= 0; n
< len
; n
++, src
+= delta
)
156 /* Advance to the next element. */
161 while (count
[n
] == extent
[n
])
163 /* When we get to the end of a dimension, reset it and increment
164 the next dimension. */
166 /* We could precalculate these products, but this is a less
167 frequently used path so probably not worth it. */
168 base
-= sstride
[n
] * extent
[n
];
169 dest
-= dstride
[n
] * extent
[n
];
173 /* Break out of the look. */
188 extern void msum_r4 (gfc_array_r4
* const restrict
,
189 gfc_array_r4
* const restrict
, const index_type
* const restrict
,
190 gfc_array_l1
* const restrict
);
191 export_proto(msum_r4
);
194 msum_r4 (gfc_array_r4
* const restrict retarray
,
195 gfc_array_r4
* const restrict array
,
196 const index_type
* const restrict pdim
,
197 gfc_array_l1
* const restrict mask
)
199 index_type count
[GFC_MAX_DIMENSIONS
];
200 index_type extent
[GFC_MAX_DIMENSIONS
];
201 index_type sstride
[GFC_MAX_DIMENSIONS
];
202 index_type dstride
[GFC_MAX_DIMENSIONS
];
203 index_type mstride
[GFC_MAX_DIMENSIONS
];
204 GFC_REAL_4
* restrict dest
;
205 const GFC_REAL_4
* restrict base
;
206 const GFC_LOGICAL_1
* restrict mbase
;
216 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
218 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
222 mbase
= mask
->base_addr
;
224 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
226 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
227 #ifdef HAVE_GFC_LOGICAL_16
231 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
233 runtime_error ("Funny sized logical array");
235 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
236 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
238 for (n
= 0; n
< dim
; n
++)
240 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
241 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
242 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
248 for (n
= dim
; n
< rank
; n
++)
250 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
251 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
252 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
258 if (retarray
->base_addr
== NULL
)
260 size_t alloc_size
, str
;
262 for (n
= 0; n
< rank
; n
++)
267 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
269 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
273 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
275 retarray
->offset
= 0;
276 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
280 /* Make sure we have a zero-sized array. */
281 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
285 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_REAL_4
));
290 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
291 runtime_error ("rank of return array incorrect in SUM intrinsic");
293 if (unlikely (compile_options
.bounds_check
))
295 bounds_ifunction_return ((array_t
*) retarray
, extent
,
296 "return value", "SUM");
297 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
298 "MASK argument", "SUM");
302 for (n
= 0; n
< rank
; n
++)
305 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
310 dest
= retarray
->base_addr
;
311 base
= array
->base_addr
;
315 const GFC_REAL_4
* restrict src
;
316 const GFC_LOGICAL_1
* restrict msrc
;
323 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
331 /* Advance to the next element. */
337 while (count
[n
] == extent
[n
])
339 /* When we get to the end of a dimension, reset it and increment
340 the next dimension. */
342 /* We could precalculate these products, but this is a less
343 frequently used path so probably not worth it. */
344 base
-= sstride
[n
] * extent
[n
];
345 mbase
-= mstride
[n
] * extent
[n
];
346 dest
-= dstride
[n
] * extent
[n
];
350 /* Break out of the look. */
366 extern void ssum_r4 (gfc_array_r4
* const restrict
,
367 gfc_array_r4
* const restrict
, const index_type
* const restrict
,
369 export_proto(ssum_r4
);
372 ssum_r4 (gfc_array_r4
* const restrict retarray
,
373 gfc_array_r4
* const restrict array
,
374 const index_type
* const restrict pdim
,
375 GFC_LOGICAL_4
* mask
)
377 index_type count
[GFC_MAX_DIMENSIONS
];
378 index_type extent
[GFC_MAX_DIMENSIONS
];
379 index_type dstride
[GFC_MAX_DIMENSIONS
];
380 GFC_REAL_4
* restrict dest
;
388 sum_r4 (retarray
, array
, pdim
);
391 /* Make dim zero based to avoid confusion. */
393 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
395 for (n
= 0; n
< dim
; n
++)
397 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
403 for (n
= dim
; n
< rank
; n
++)
406 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
412 if (retarray
->base_addr
== NULL
)
414 size_t alloc_size
, str
;
416 for (n
= 0; n
< rank
; n
++)
421 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
423 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
427 retarray
->offset
= 0;
428 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
430 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
434 /* Make sure we have a zero-sized array. */
435 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
439 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_REAL_4
));
443 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
444 runtime_error ("rank of return array incorrect in"
445 " SUM intrinsic: is %ld, should be %ld",
446 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
449 if (unlikely (compile_options
.bounds_check
))
451 for (n
=0; n
< rank
; n
++)
453 index_type ret_extent
;
455 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
456 if (extent
[n
] != ret_extent
)
457 runtime_error ("Incorrect extent in return value of"
458 " SUM intrinsic in dimension %ld:"
459 " is %ld, should be %ld", (long int) n
+ 1,
460 (long int) ret_extent
, (long int) extent
[n
]);
465 for (n
= 0; n
< rank
; n
++)
468 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
471 dest
= retarray
->base_addr
;
479 while (count
[n
] == extent
[n
])
481 /* When we get to the end of a dimension, reset it and increment
482 the next dimension. */
484 /* We could precalculate these products, but this is a less
485 frequently used path so probably not worth it. */
486 dest
-= dstride
[n
] * extent
[n
];