1 /* Implementation of the SUM intrinsic
2 Copyright (C) 2002-2014 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"
31 #if defined (HAVE_GFC_COMPLEX_10) && defined (HAVE_GFC_COMPLEX_10)
34 extern void sum_c10 (gfc_array_c10
* const restrict
,
35 gfc_array_c10
* const restrict
, const index_type
* const restrict
);
36 export_proto(sum_c10
);
39 sum_c10 (gfc_array_c10
* const restrict retarray
,
40 gfc_array_c10
* const restrict array
,
41 const index_type
* const restrict pdim
)
43 index_type count
[GFC_MAX_DIMENSIONS
];
44 index_type extent
[GFC_MAX_DIMENSIONS
];
45 index_type sstride
[GFC_MAX_DIMENSIONS
];
46 index_type dstride
[GFC_MAX_DIMENSIONS
];
47 const GFC_COMPLEX_10
* restrict base
;
48 GFC_COMPLEX_10
* restrict dest
;
56 /* Make dim zero based to avoid confusion. */
58 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
60 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
63 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
65 for (n
= 0; n
< dim
; n
++)
67 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
68 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
73 for (n
= dim
; n
< rank
; n
++)
75 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
76 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
82 if (retarray
->base_addr
== NULL
)
84 size_t alloc_size
, str
;
86 for (n
= 0; n
< rank
; n
++)
91 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
93 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
98 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
100 alloc_size
= sizeof (GFC_COMPLEX_10
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
103 retarray
->base_addr
= xmalloc (alloc_size
);
106 /* Make sure we have a zero-sized array. */
107 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
114 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
115 runtime_error ("rank of return array incorrect in"
116 " SUM intrinsic: is %ld, should be %ld",
117 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
120 if (unlikely (compile_options
.bounds_check
))
121 bounds_ifunction_return ((array_t
*) retarray
, extent
,
122 "return value", "SUM");
125 for (n
= 0; n
< rank
; n
++)
128 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
133 base
= array
->base_addr
;
134 dest
= retarray
->base_addr
;
137 while (continue_loop
)
139 const GFC_COMPLEX_10
* restrict src
;
140 GFC_COMPLEX_10 result
;
149 for (n
= 0; n
< len
; n
++, src
+= delta
)
158 /* Advance to the next element. */
163 while (count
[n
] == extent
[n
])
165 /* When we get to the end of a dimension, reset it and increment
166 the next dimension. */
168 /* We could precalculate these products, but this is a less
169 frequently used path so probably not worth it. */
170 base
-= sstride
[n
] * extent
[n
];
171 dest
-= dstride
[n
] * extent
[n
];
175 /* Break out of the look. */
190 extern void msum_c10 (gfc_array_c10
* const restrict
,
191 gfc_array_c10
* const restrict
, const index_type
* const restrict
,
192 gfc_array_l1
* const restrict
);
193 export_proto(msum_c10
);
196 msum_c10 (gfc_array_c10
* const restrict retarray
,
197 gfc_array_c10
* const restrict array
,
198 const index_type
* const restrict pdim
,
199 gfc_array_l1
* const restrict mask
)
201 index_type count
[GFC_MAX_DIMENSIONS
];
202 index_type extent
[GFC_MAX_DIMENSIONS
];
203 index_type sstride
[GFC_MAX_DIMENSIONS
];
204 index_type dstride
[GFC_MAX_DIMENSIONS
];
205 index_type mstride
[GFC_MAX_DIMENSIONS
];
206 GFC_COMPLEX_10
* restrict dest
;
207 const GFC_COMPLEX_10
* restrict base
;
208 const GFC_LOGICAL_1
* restrict mbase
;
218 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
220 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
224 mbase
= mask
->base_addr
;
226 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
228 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
229 #ifdef HAVE_GFC_LOGICAL_16
233 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
235 runtime_error ("Funny sized logical array");
237 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
238 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
240 for (n
= 0; n
< dim
; n
++)
242 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
243 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
244 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
250 for (n
= dim
; n
< rank
; n
++)
252 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
253 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
254 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
260 if (retarray
->base_addr
== NULL
)
262 size_t alloc_size
, str
;
264 for (n
= 0; n
< rank
; n
++)
269 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
271 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
275 alloc_size
= sizeof (GFC_COMPLEX_10
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
278 retarray
->offset
= 0;
279 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
283 /* Make sure we have a zero-sized array. */
284 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
288 retarray
->base_addr
= xmalloc (alloc_size
);
293 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
294 runtime_error ("rank of return array incorrect in SUM intrinsic");
296 if (unlikely (compile_options
.bounds_check
))
298 bounds_ifunction_return ((array_t
*) retarray
, extent
,
299 "return value", "SUM");
300 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
301 "MASK argument", "SUM");
305 for (n
= 0; n
< rank
; n
++)
308 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
313 dest
= retarray
->base_addr
;
314 base
= array
->base_addr
;
318 const GFC_COMPLEX_10
* restrict src
;
319 const GFC_LOGICAL_1
* restrict msrc
;
320 GFC_COMPLEX_10 result
;
326 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
334 /* Advance to the next element. */
340 while (count
[n
] == extent
[n
])
342 /* When we get to the end of a dimension, reset it and increment
343 the next dimension. */
345 /* We could precalculate these products, but this is a less
346 frequently used path so probably not worth it. */
347 base
-= sstride
[n
] * extent
[n
];
348 mbase
-= mstride
[n
] * extent
[n
];
349 dest
-= dstride
[n
] * extent
[n
];
353 /* Break out of the look. */
369 extern void ssum_c10 (gfc_array_c10
* const restrict
,
370 gfc_array_c10
* const restrict
, const index_type
* const restrict
,
372 export_proto(ssum_c10
);
375 ssum_c10 (gfc_array_c10
* const restrict retarray
,
376 gfc_array_c10
* const restrict array
,
377 const index_type
* const restrict pdim
,
378 GFC_LOGICAL_4
* mask
)
380 index_type count
[GFC_MAX_DIMENSIONS
];
381 index_type extent
[GFC_MAX_DIMENSIONS
];
382 index_type dstride
[GFC_MAX_DIMENSIONS
];
383 GFC_COMPLEX_10
* restrict dest
;
391 sum_c10 (retarray
, array
, pdim
);
394 /* Make dim zero based to avoid confusion. */
396 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
398 for (n
= 0; n
< dim
; n
++)
400 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
406 for (n
= dim
; n
< rank
; n
++)
409 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
415 if (retarray
->base_addr
== NULL
)
417 size_t alloc_size
, str
;
419 for (n
= 0; n
< rank
; n
++)
424 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
426 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
430 retarray
->offset
= 0;
431 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
433 alloc_size
= sizeof (GFC_COMPLEX_10
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
438 /* Make sure we have a zero-sized array. */
439 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
443 retarray
->base_addr
= xmalloc (alloc_size
);
447 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
448 runtime_error ("rank of return array incorrect in"
449 " SUM intrinsic: is %ld, should be %ld",
450 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
453 if (unlikely (compile_options
.bounds_check
))
455 for (n
=0; n
< rank
; n
++)
457 index_type ret_extent
;
459 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
460 if (extent
[n
] != ret_extent
)
461 runtime_error ("Incorrect extent in return value of"
462 " SUM intrinsic in dimension %ld:"
463 " is %ld, should be %ld", (long int) n
+ 1,
464 (long int) ret_extent
, (long int) extent
[n
]);
469 for (n
= 0; n
< rank
; n
++)
472 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
475 dest
= retarray
->base_addr
;
483 while (count
[n
] == extent
[n
])
485 /* When we get to the end of a dimension, reset it and increment
486 the next dimension. */
488 /* We could precalculate these products, but this is a less
489 frequently used path so probably not worth it. */
490 dest
-= dstride
[n
] * extent
[n
];