]>
git.ipfire.org Git - thirdparty/gcc.git/blob - libgfortran/generated/sum_c16.c
1 /* Implementation of the SUM intrinsic
2 Copyright (C) 2002-2023 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"
29 #if defined (HAVE_GFC_COMPLEX_16) && defined (HAVE_GFC_COMPLEX_16)
32 extern void sum_c16 (gfc_array_c16
* const restrict
,
33 gfc_array_c16
* const restrict
, const index_type
* const restrict
);
34 export_proto(sum_c16
);
37 sum_c16 (gfc_array_c16
* const restrict retarray
,
38 gfc_array_c16
* const restrict array
,
39 const index_type
* const restrict pdim
)
41 index_type count
[GFC_MAX_DIMENSIONS
];
42 index_type extent
[GFC_MAX_DIMENSIONS
];
43 index_type sstride
[GFC_MAX_DIMENSIONS
];
44 index_type dstride
[GFC_MAX_DIMENSIONS
];
45 const GFC_COMPLEX_16
* restrict base
;
46 GFC_COMPLEX_16
* restrict dest
;
54 /* Make dim zero based to avoid confusion. */
55 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
58 if (unlikely (dim
< 0 || dim
> rank
))
60 runtime_error ("Dim argument incorrect in SUM intrinsic: "
61 "is %ld, should be between 1 and %ld",
62 (long int) dim
+ 1, (long int) rank
+ 1);
65 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
68 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
70 for (n
= 0; n
< dim
; n
++)
72 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
73 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
78 for (n
= dim
; n
< rank
; n
++)
80 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
81 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
87 if (retarray
->base_addr
== NULL
)
89 size_t alloc_size
, str
;
91 for (n
= 0; n
< rank
; n
++)
96 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
98 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
102 retarray
->offset
= 0;
103 retarray
->dtype
.rank
= rank
;
105 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
107 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_COMPLEX_16
));
110 /* Make sure we have a zero-sized array. */
111 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
118 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
119 runtime_error ("rank of return array incorrect in"
120 " SUM intrinsic: is %ld, should be %ld",
121 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
124 if (unlikely (compile_options
.bounds_check
))
125 bounds_ifunction_return ((array_t
*) retarray
, extent
,
126 "return value", "SUM");
129 for (n
= 0; n
< rank
; n
++)
132 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
137 base
= array
->base_addr
;
138 dest
= retarray
->base_addr
;
141 while (continue_loop
)
143 const GFC_COMPLEX_16
* restrict src
;
144 GFC_COMPLEX_16 result
;
153 #if ! defined HAVE_BACK_ARG
154 for (n
= 0; n
< len
; n
++, src
+= delta
)
164 /* Advance to the next element. */
169 while (count
[n
] == extent
[n
])
171 /* When we get to the end of a dimension, reset it and increment
172 the next dimension. */
174 /* We could precalculate these products, but this is a less
175 frequently used path so probably not worth it. */
176 base
-= sstride
[n
] * extent
[n
];
177 dest
-= dstride
[n
] * extent
[n
];
181 /* Break out of the loop. */
196 extern void msum_c16 (gfc_array_c16
* const restrict
,
197 gfc_array_c16
* const restrict
, const index_type
* const restrict
,
198 gfc_array_l1
* const restrict
);
199 export_proto(msum_c16
);
202 msum_c16 (gfc_array_c16
* const restrict retarray
,
203 gfc_array_c16
* const restrict array
,
204 const index_type
* const restrict pdim
,
205 gfc_array_l1
* const restrict mask
)
207 index_type count
[GFC_MAX_DIMENSIONS
];
208 index_type extent
[GFC_MAX_DIMENSIONS
];
209 index_type sstride
[GFC_MAX_DIMENSIONS
];
210 index_type dstride
[GFC_MAX_DIMENSIONS
];
211 index_type mstride
[GFC_MAX_DIMENSIONS
];
212 GFC_COMPLEX_16
* restrict dest
;
213 const GFC_COMPLEX_16
* restrict base
;
214 const GFC_LOGICAL_1
* restrict mbase
;
226 sum_c16 (retarray
, array
, pdim
, back
);
228 sum_c16 (retarray
, array
, pdim
);
234 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
237 if (unlikely (dim
< 0 || dim
> rank
))
239 runtime_error ("Dim argument incorrect in SUM intrinsic: "
240 "is %ld, should be between 1 and %ld",
241 (long int) dim
+ 1, (long int) rank
+ 1);
244 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
248 mbase
= mask
->base_addr
;
250 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
252 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
253 #ifdef HAVE_GFC_LOGICAL_16
257 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
259 runtime_error ("Funny sized logical array");
261 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
262 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
264 for (n
= 0; n
< dim
; n
++)
266 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
267 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
268 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
274 for (n
= dim
; n
< rank
; n
++)
276 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
277 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
278 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
284 if (retarray
->base_addr
== NULL
)
286 size_t alloc_size
, str
;
288 for (n
= 0; n
< rank
; n
++)
293 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
295 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
299 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
301 retarray
->offset
= 0;
302 retarray
->dtype
.rank
= rank
;
304 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_COMPLEX_16
));
307 /* Make sure we have a zero-sized array. */
308 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
314 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
315 runtime_error ("rank of return array incorrect in SUM intrinsic");
317 if (unlikely (compile_options
.bounds_check
))
319 bounds_ifunction_return ((array_t
*) retarray
, extent
,
320 "return value", "SUM");
321 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
322 "MASK argument", "SUM");
326 for (n
= 0; n
< rank
; n
++)
329 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
334 dest
= retarray
->base_addr
;
335 base
= array
->base_addr
;
339 const GFC_COMPLEX_16
* restrict src
;
340 const GFC_LOGICAL_1
* restrict msrc
;
341 GFC_COMPLEX_16 result
;
347 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
355 /* Advance to the next element. */
361 while (count
[n
] == extent
[n
])
363 /* When we get to the end of a dimension, reset it and increment
364 the next dimension. */
366 /* We could precalculate these products, but this is a less
367 frequently used path so probably not worth it. */
368 base
-= sstride
[n
] * extent
[n
];
369 mbase
-= mstride
[n
] * extent
[n
];
370 dest
-= dstride
[n
] * extent
[n
];
374 /* Break out of the loop. */
390 extern void ssum_c16 (gfc_array_c16
* const restrict
,
391 gfc_array_c16
* const restrict
, const index_type
* const restrict
,
393 export_proto(ssum_c16
);
396 ssum_c16 (gfc_array_c16
* const restrict retarray
,
397 gfc_array_c16
* const restrict array
,
398 const index_type
* const restrict pdim
,
399 GFC_LOGICAL_4
* mask
)
401 index_type count
[GFC_MAX_DIMENSIONS
];
402 index_type extent
[GFC_MAX_DIMENSIONS
];
403 index_type dstride
[GFC_MAX_DIMENSIONS
];
404 GFC_COMPLEX_16
* restrict dest
;
410 if (mask
== NULL
|| *mask
)
413 sum_c16 (retarray
, array
, pdim
, back
);
415 sum_c16 (retarray
, array
, pdim
);
419 /* Make dim zero based to avoid confusion. */
421 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
423 if (unlikely (dim
< 0 || dim
> rank
))
425 runtime_error ("Dim argument incorrect in SUM intrinsic: "
426 "is %ld, should be between 1 and %ld",
427 (long int) dim
+ 1, (long int) rank
+ 1);
430 for (n
= 0; n
< dim
; n
++)
432 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
438 for (n
= dim
; n
< rank
; n
++)
441 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
447 if (retarray
->base_addr
== NULL
)
449 size_t alloc_size
, str
;
451 for (n
= 0; n
< rank
; n
++)
456 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
458 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
462 retarray
->offset
= 0;
463 retarray
->dtype
.rank
= rank
;
465 alloc_size
= GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1) * extent
[rank
-1];
467 retarray
->base_addr
= xmallocarray (alloc_size
, sizeof (GFC_COMPLEX_16
));
470 /* Make sure we have a zero-sized array. */
471 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
477 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
478 runtime_error ("rank of return array incorrect in"
479 " SUM intrinsic: is %ld, should be %ld",
480 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
483 if (unlikely (compile_options
.bounds_check
))
485 for (n
=0; n
< rank
; n
++)
487 index_type ret_extent
;
489 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
490 if (extent
[n
] != ret_extent
)
491 runtime_error ("Incorrect extent in return value of"
492 " SUM intrinsic in dimension %ld:"
493 " is %ld, should be %ld", (long int) n
+ 1,
494 (long int) ret_extent
, (long int) extent
[n
]);
499 for (n
= 0; n
< rank
; n
++)
502 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
505 dest
= retarray
->base_addr
;
513 while (count
[n
] == extent
[n
])
515 /* When we get to the end of a dimension, reset it and increment
516 the next dimension. */
518 /* We could precalculate these products, but this is a less
519 frequently used path so probably not worth it. */
520 dest
-= dstride
[n
] * extent
[n
];