1 /* Implementation of the SUM 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"
36 #if defined (HAVE_GFC_COMPLEX_8) && defined (HAVE_GFC_COMPLEX_8)
39 extern void sum_c8 (gfc_array_c8
* const restrict
,
40 gfc_array_c8
* const restrict
, const index_type
* const restrict
);
44 sum_c8 (gfc_array_c8
* const restrict retarray
,
45 gfc_array_c8
* const restrict array
,
46 const index_type
* const restrict pdim
)
48 index_type count
[GFC_MAX_DIMENSIONS
];
49 index_type extent
[GFC_MAX_DIMENSIONS
];
50 index_type sstride
[GFC_MAX_DIMENSIONS
];
51 index_type dstride
[GFC_MAX_DIMENSIONS
];
52 const GFC_COMPLEX_8
* restrict base
;
53 GFC_COMPLEX_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
;
68 delta
= array
->dim
[dim
].stride
;
70 for (n
= 0; n
< dim
; n
++)
72 sstride
[n
] = array
->dim
[n
].stride
;
73 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
78 for (n
= dim
; n
< rank
; n
++)
80 sstride
[n
] = array
->dim
[n
+ 1].stride
;
82 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
88 if (retarray
->data
== NULL
)
92 for (n
= 0; n
< rank
; n
++)
94 retarray
->dim
[n
].lbound
= 0;
95 retarray
->dim
[n
].ubound
= extent
[n
]-1;
97 retarray
->dim
[n
].stride
= 1;
99 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
102 retarray
->offset
= 0;
103 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
105 alloc_size
= sizeof (GFC_COMPLEX_8
) * retarray
->dim
[rank
-1].stride
110 /* Make sure we have a zero-sized array. */
111 retarray
->dim
[0].lbound
= 0;
112 retarray
->dim
[0].ubound
= -1;
116 retarray
->data
= internal_malloc_size (alloc_size
);
120 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
121 runtime_error ("rank of return array incorrect in"
122 " SUM intrinsic: is %ld, should be %ld",
123 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
126 if (unlikely (compile_options
.bounds_check
))
128 for (n
=0; n
< rank
; n
++)
130 index_type ret_extent
;
132 ret_extent
= retarray
->dim
[n
].ubound
+ 1
133 - retarray
->dim
[n
].lbound
;
134 if (extent
[n
] != ret_extent
)
135 runtime_error ("Incorrect extent in return value of"
136 " SUM intrinsic in dimension %ld:"
137 " is %ld, should be %ld", (long int) n
+ 1,
138 (long int) ret_extent
, (long int) extent
[n
]);
143 for (n
= 0; n
< rank
; n
++)
146 dstride
[n
] = retarray
->dim
[n
].stride
;
152 dest
= retarray
->data
;
155 while (continue_loop
)
157 const GFC_COMPLEX_8
* restrict src
;
158 GFC_COMPLEX_8 result
;
167 for (n
= 0; n
< len
; n
++, src
+= delta
)
175 /* Advance to the next element. */
180 while (count
[n
] == extent
[n
])
182 /* When we get to the end of a dimension, reset it and increment
183 the next dimension. */
185 /* We could precalculate these products, but this is a less
186 frequently used path so probably not worth it. */
187 base
-= sstride
[n
] * extent
[n
];
188 dest
-= dstride
[n
] * extent
[n
];
192 /* Break out of the look. */
207 extern void msum_c8 (gfc_array_c8
* const restrict
,
208 gfc_array_c8
* const restrict
, const index_type
* const restrict
,
209 gfc_array_l1
* const restrict
);
210 export_proto(msum_c8
);
213 msum_c8 (gfc_array_c8
* const restrict retarray
,
214 gfc_array_c8
* const restrict array
,
215 const index_type
* const restrict pdim
,
216 gfc_array_l1
* const restrict mask
)
218 index_type count
[GFC_MAX_DIMENSIONS
];
219 index_type extent
[GFC_MAX_DIMENSIONS
];
220 index_type sstride
[GFC_MAX_DIMENSIONS
];
221 index_type dstride
[GFC_MAX_DIMENSIONS
];
222 index_type mstride
[GFC_MAX_DIMENSIONS
];
223 GFC_COMPLEX_8
* restrict dest
;
224 const GFC_COMPLEX_8
* restrict base
;
225 const GFC_LOGICAL_1
* restrict mbase
;
235 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
237 len
= array
->dim
[dim
].ubound
+ 1 - array
->dim
[dim
].lbound
;
243 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
245 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
246 #ifdef HAVE_GFC_LOGICAL_16
250 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
252 runtime_error ("Funny sized logical array");
254 delta
= array
->dim
[dim
].stride
;
255 mdelta
= mask
->dim
[dim
].stride
* mask_kind
;
257 for (n
= 0; n
< dim
; n
++)
259 sstride
[n
] = array
->dim
[n
].stride
;
260 mstride
[n
] = mask
->dim
[n
].stride
* mask_kind
;
261 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
267 for (n
= dim
; n
< rank
; n
++)
269 sstride
[n
] = array
->dim
[n
+ 1].stride
;
270 mstride
[n
] = mask
->dim
[n
+ 1].stride
* mask_kind
;
272 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
278 if (retarray
->data
== NULL
)
282 for (n
= 0; n
< rank
; n
++)
284 retarray
->dim
[n
].lbound
= 0;
285 retarray
->dim
[n
].ubound
= extent
[n
]-1;
287 retarray
->dim
[n
].stride
= 1;
289 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
292 alloc_size
= sizeof (GFC_COMPLEX_8
) * retarray
->dim
[rank
-1].stride
295 retarray
->offset
= 0;
296 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
300 /* Make sure we have a zero-sized array. */
301 retarray
->dim
[0].lbound
= 0;
302 retarray
->dim
[0].ubound
= -1;
306 retarray
->data
= internal_malloc_size (alloc_size
);
311 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
312 runtime_error ("rank of return array incorrect in SUM intrinsic");
314 if (unlikely (compile_options
.bounds_check
))
316 for (n
=0; n
< rank
; n
++)
318 index_type ret_extent
;
320 ret_extent
= retarray
->dim
[n
].ubound
+ 1
321 - retarray
->dim
[n
].lbound
;
322 if (extent
[n
] != ret_extent
)
323 runtime_error ("Incorrect extent in return value of"
324 " SUM intrinsic in dimension %ld:"
325 " is %ld, should be %ld", (long int) n
+ 1,
326 (long int) ret_extent
, (long int) extent
[n
]);
328 for (n
=0; n
<= rank
; n
++)
330 index_type mask_extent
, array_extent
;
332 array_extent
= array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
333 mask_extent
= mask
->dim
[n
].ubound
+ 1 - mask
->dim
[n
].lbound
;
334 if (array_extent
!= mask_extent
)
335 runtime_error ("Incorrect extent in MASK argument of"
336 " SUM intrinsic in dimension %ld:"
337 " is %ld, should be %ld", (long int) n
+ 1,
338 (long int) mask_extent
, (long int) array_extent
);
343 for (n
= 0; n
< rank
; n
++)
346 dstride
[n
] = retarray
->dim
[n
].stride
;
351 dest
= retarray
->data
;
356 const GFC_COMPLEX_8
* restrict src
;
357 const GFC_LOGICAL_1
* restrict msrc
;
358 GFC_COMPLEX_8 result
;
368 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
377 /* Advance to the next element. */
383 while (count
[n
] == extent
[n
])
385 /* When we get to the end of a dimension, reset it and increment
386 the next dimension. */
388 /* We could precalculate these products, but this is a less
389 frequently used path so probably not worth it. */
390 base
-= sstride
[n
] * extent
[n
];
391 mbase
-= mstride
[n
] * extent
[n
];
392 dest
-= dstride
[n
] * extent
[n
];
396 /* Break out of the look. */
412 extern void ssum_c8 (gfc_array_c8
* const restrict
,
413 gfc_array_c8
* const restrict
, const index_type
* const restrict
,
415 export_proto(ssum_c8
);
418 ssum_c8 (gfc_array_c8
* const restrict retarray
,
419 gfc_array_c8
* const restrict array
,
420 const index_type
* const restrict pdim
,
421 GFC_LOGICAL_4
* mask
)
423 index_type count
[GFC_MAX_DIMENSIONS
];
424 index_type extent
[GFC_MAX_DIMENSIONS
];
425 index_type sstride
[GFC_MAX_DIMENSIONS
];
426 index_type dstride
[GFC_MAX_DIMENSIONS
];
427 GFC_COMPLEX_8
* restrict dest
;
435 sum_c8 (retarray
, array
, pdim
);
438 /* Make dim zero based to avoid confusion. */
440 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
442 for (n
= 0; n
< dim
; n
++)
444 sstride
[n
] = array
->dim
[n
].stride
;
445 extent
[n
] = array
->dim
[n
].ubound
+ 1 - array
->dim
[n
].lbound
;
451 for (n
= dim
; n
< rank
; n
++)
453 sstride
[n
] = array
->dim
[n
+ 1].stride
;
455 array
->dim
[n
+ 1].ubound
+ 1 - array
->dim
[n
+ 1].lbound
;
461 if (retarray
->data
== NULL
)
465 for (n
= 0; n
< rank
; n
++)
467 retarray
->dim
[n
].lbound
= 0;
468 retarray
->dim
[n
].ubound
= extent
[n
]-1;
470 retarray
->dim
[n
].stride
= 1;
472 retarray
->dim
[n
].stride
= retarray
->dim
[n
-1].stride
* extent
[n
-1];
475 retarray
->offset
= 0;
476 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
478 alloc_size
= sizeof (GFC_COMPLEX_8
) * retarray
->dim
[rank
-1].stride
483 /* Make sure we have a zero-sized array. */
484 retarray
->dim
[0].lbound
= 0;
485 retarray
->dim
[0].ubound
= -1;
489 retarray
->data
= internal_malloc_size (alloc_size
);
493 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
494 runtime_error ("rank of return array incorrect in"
495 " SUM intrinsic: is %ld, should be %ld",
496 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
499 if (unlikely (compile_options
.bounds_check
))
501 for (n
=0; n
< rank
; n
++)
503 index_type ret_extent
;
505 ret_extent
= retarray
->dim
[n
].ubound
+ 1
506 - retarray
->dim
[n
].lbound
;
507 if (extent
[n
] != ret_extent
)
508 runtime_error ("Incorrect extent in return value of"
509 " SUM intrinsic in dimension %ld:"
510 " is %ld, should be %ld", (long int) n
+ 1,
511 (long int) ret_extent
, (long int) extent
[n
]);
516 for (n
= 0; n
< rank
; n
++)
519 dstride
[n
] = retarray
->dim
[n
].stride
;
522 dest
= retarray
->data
;
530 while (count
[n
] == extent
[n
])
532 /* When we get to the end of a dimension, reset it and increment
533 the next dimension. */
535 /* We could precalculate these products, but this is a less
536 frequently used path so probably not worth it. */
537 dest
-= dstride
[n
] * extent
[n
];