1 /* Implementation of the PRODUCT intrinsic
2 Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran 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 product_c10 (gfc_array_c10
* const restrict
,
35 gfc_array_c10
* const restrict
, const index_type
* const restrict
);
36 export_proto(product_c10
);
39 product_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
->data
== 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
->data
= internal_malloc_size (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 " PRODUCT 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", "PRODUCT");
125 for (n
= 0; n
< rank
; n
++)
128 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
134 dest
= retarray
->data
;
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 mproduct_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(mproduct_c10
);
196 mproduct_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
);
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
->data
== 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
->data
= internal_malloc_size (alloc_size
);
293 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
294 runtime_error ("rank of return array incorrect in PRODUCT intrinsic");
296 if (unlikely (compile_options
.bounds_check
))
298 bounds_ifunction_return ((array_t
*) retarray
, extent
,
299 "return value", "PRODUCT");
300 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
301 "MASK argument", "PRODUCT");
305 for (n
= 0; n
< rank
; n
++)
308 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
313 dest
= retarray
->data
;
318 const GFC_COMPLEX_10
* restrict src
;
319 const GFC_LOGICAL_1
* restrict msrc
;
320 GFC_COMPLEX_10 result
;
330 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
339 /* Advance to the next element. */
345 while (count
[n
] == extent
[n
])
347 /* When we get to the end of a dimension, reset it and increment
348 the next dimension. */
350 /* We could precalculate these products, but this is a less
351 frequently used path so probably not worth it. */
352 base
-= sstride
[n
] * extent
[n
];
353 mbase
-= mstride
[n
] * extent
[n
];
354 dest
-= dstride
[n
] * extent
[n
];
358 /* Break out of the look. */
374 extern void sproduct_c10 (gfc_array_c10
* const restrict
,
375 gfc_array_c10
* const restrict
, const index_type
* const restrict
,
377 export_proto(sproduct_c10
);
380 sproduct_c10 (gfc_array_c10
* const restrict retarray
,
381 gfc_array_c10
* const restrict array
,
382 const index_type
* const restrict pdim
,
383 GFC_LOGICAL_4
* mask
)
385 index_type count
[GFC_MAX_DIMENSIONS
];
386 index_type extent
[GFC_MAX_DIMENSIONS
];
387 index_type dstride
[GFC_MAX_DIMENSIONS
];
388 GFC_COMPLEX_10
* restrict dest
;
396 product_c10 (retarray
, array
, pdim
);
399 /* Make dim zero based to avoid confusion. */
401 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
403 for (n
= 0; n
< dim
; n
++)
405 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
411 for (n
= dim
; n
< rank
; n
++)
414 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
420 if (retarray
->data
== NULL
)
422 size_t alloc_size
, str
;
424 for (n
= 0; n
< rank
; n
++)
429 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
431 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
435 retarray
->offset
= 0;
436 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
438 alloc_size
= sizeof (GFC_COMPLEX_10
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
443 /* Make sure we have a zero-sized array. */
444 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
448 retarray
->data
= internal_malloc_size (alloc_size
);
452 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
453 runtime_error ("rank of return array incorrect in"
454 " PRODUCT intrinsic: is %ld, should be %ld",
455 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
458 if (unlikely (compile_options
.bounds_check
))
460 for (n
=0; n
< rank
; n
++)
462 index_type ret_extent
;
464 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
465 if (extent
[n
] != ret_extent
)
466 runtime_error ("Incorrect extent in return value of"
467 " PRODUCT intrinsic in dimension %ld:"
468 " is %ld, should be %ld", (long int) n
+ 1,
469 (long int) ret_extent
, (long int) extent
[n
]);
474 for (n
= 0; n
< rank
; n
++)
477 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
480 dest
= retarray
->data
;
488 while (count
[n
] == extent
[n
])
490 /* When we get to the end of a dimension, reset it and increment
491 the next dimension. */
493 /* We could precalculate these products, but this is a less
494 frequently used path so probably not worth it. */
495 dest
-= dstride
[n
] * extent
[n
];