1760c2415Smrg /* Special implementation of the SPREAD intrinsic
2*0bfacb9bSmrg Copyright (C) 2008-2020 Free Software Foundation, Inc.
3760c2415Smrg Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>, based on
4760c2415Smrg spread_generic.c written by Paul Brook <paul@nowt.org>
5760c2415Smrg
6760c2415Smrg This file is part of the GNU Fortran runtime library (libgfortran).
7760c2415Smrg
8760c2415Smrg Libgfortran is free software; you can redistribute it and/or
9760c2415Smrg modify it under the terms of the GNU General Public
10760c2415Smrg License as published by the Free Software Foundation; either
11760c2415Smrg version 3 of the License, or (at your option) any later version.
12760c2415Smrg
13760c2415Smrg Ligbfortran is distributed in the hope that it will be useful,
14760c2415Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
15760c2415Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16760c2415Smrg GNU General Public License for more details.
17760c2415Smrg
18760c2415Smrg Under Section 7 of GPL version 3, you are granted additional
19760c2415Smrg permissions described in the GCC Runtime Library Exception, version
20760c2415Smrg 3.1, as published by the Free Software Foundation.
21760c2415Smrg
22760c2415Smrg You should have received a copy of the GNU General Public License and
23760c2415Smrg a copy of the GCC Runtime Library Exception along with this program;
24760c2415Smrg see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
25760c2415Smrg <http://www.gnu.org/licenses/>. */
26760c2415Smrg
27760c2415Smrg #include "libgfortran.h"
28760c2415Smrg #include <string.h>
29760c2415Smrg
30760c2415Smrg
31760c2415Smrg #if defined (HAVE_GFC_COMPLEX_8)
32760c2415Smrg
33760c2415Smrg void
spread_c8(gfc_array_c8 * ret,const gfc_array_c8 * source,const index_type along,const index_type pncopies)34760c2415Smrg spread_c8 (gfc_array_c8 *ret, const gfc_array_c8 *source,
35760c2415Smrg const index_type along, const index_type pncopies)
36760c2415Smrg {
37760c2415Smrg /* r.* indicates the return array. */
38760c2415Smrg index_type rstride[GFC_MAX_DIMENSIONS];
39760c2415Smrg index_type rstride0;
40760c2415Smrg index_type rdelta = 0;
41760c2415Smrg index_type rrank;
42760c2415Smrg index_type rs;
43760c2415Smrg GFC_COMPLEX_8 *rptr;
44760c2415Smrg GFC_COMPLEX_8 * restrict dest;
45760c2415Smrg /* s.* indicates the source array. */
46760c2415Smrg index_type sstride[GFC_MAX_DIMENSIONS];
47760c2415Smrg index_type sstride0;
48760c2415Smrg index_type srank;
49760c2415Smrg const GFC_COMPLEX_8 *sptr;
50760c2415Smrg
51760c2415Smrg index_type count[GFC_MAX_DIMENSIONS];
52760c2415Smrg index_type extent[GFC_MAX_DIMENSIONS];
53760c2415Smrg index_type n;
54760c2415Smrg index_type dim;
55760c2415Smrg index_type ncopies;
56760c2415Smrg
57760c2415Smrg srank = GFC_DESCRIPTOR_RANK(source);
58760c2415Smrg
59760c2415Smrg rrank = srank + 1;
60760c2415Smrg if (rrank > GFC_MAX_DIMENSIONS)
61760c2415Smrg runtime_error ("return rank too large in spread()");
62760c2415Smrg
63760c2415Smrg if (along > rrank)
64760c2415Smrg runtime_error ("dim outside of rank in spread()");
65760c2415Smrg
66760c2415Smrg ncopies = pncopies;
67760c2415Smrg
68760c2415Smrg if (ret->base_addr == NULL)
69760c2415Smrg {
70760c2415Smrg
71760c2415Smrg size_t ub, stride;
72760c2415Smrg
73760c2415Smrg /* The front end has signalled that we need to populate the
74760c2415Smrg return array descriptor. */
75760c2415Smrg ret->dtype.rank = rrank;
76760c2415Smrg
77760c2415Smrg dim = 0;
78760c2415Smrg rs = 1;
79760c2415Smrg for (n = 0; n < rrank; n++)
80760c2415Smrg {
81760c2415Smrg stride = rs;
82760c2415Smrg if (n == along - 1)
83760c2415Smrg {
84760c2415Smrg ub = ncopies - 1;
85760c2415Smrg rdelta = rs;
86760c2415Smrg rs *= ncopies;
87760c2415Smrg }
88760c2415Smrg else
89760c2415Smrg {
90760c2415Smrg count[dim] = 0;
91760c2415Smrg extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
92760c2415Smrg sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
93760c2415Smrg rstride[dim] = rs;
94760c2415Smrg
95760c2415Smrg ub = extent[dim] - 1;
96760c2415Smrg rs *= extent[dim];
97760c2415Smrg dim++;
98760c2415Smrg }
99760c2415Smrg GFC_DIMENSION_SET(ret->dim[n], 0, ub, stride);
100760c2415Smrg }
101760c2415Smrg ret->offset = 0;
102760c2415Smrg
103760c2415Smrg /* xmallocarray allocates a single byte for zero size. */
104760c2415Smrg ret->base_addr = xmallocarray (rs, sizeof(GFC_COMPLEX_8));
105760c2415Smrg if (rs <= 0)
106760c2415Smrg return;
107760c2415Smrg }
108760c2415Smrg else
109760c2415Smrg {
110760c2415Smrg int zero_sized;
111760c2415Smrg
112760c2415Smrg zero_sized = 0;
113760c2415Smrg
114760c2415Smrg dim = 0;
115760c2415Smrg if (GFC_DESCRIPTOR_RANK(ret) != rrank)
116760c2415Smrg runtime_error ("rank mismatch in spread()");
117760c2415Smrg
118760c2415Smrg if (unlikely (compile_options.bounds_check))
119760c2415Smrg {
120760c2415Smrg for (n = 0; n < rrank; n++)
121760c2415Smrg {
122760c2415Smrg index_type ret_extent;
123760c2415Smrg
124760c2415Smrg ret_extent = GFC_DESCRIPTOR_EXTENT(ret,n);
125760c2415Smrg if (n == along - 1)
126760c2415Smrg {
127760c2415Smrg rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
128760c2415Smrg
129760c2415Smrg if (ret_extent != ncopies)
130760c2415Smrg runtime_error("Incorrect extent in return value of SPREAD"
131760c2415Smrg " intrinsic in dimension %ld: is %ld,"
132760c2415Smrg " should be %ld", (long int) n+1,
133760c2415Smrg (long int) ret_extent, (long int) ncopies);
134760c2415Smrg }
135760c2415Smrg else
136760c2415Smrg {
137760c2415Smrg count[dim] = 0;
138760c2415Smrg extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
139760c2415Smrg if (ret_extent != extent[dim])
140760c2415Smrg runtime_error("Incorrect extent in return value of SPREAD"
141760c2415Smrg " intrinsic in dimension %ld: is %ld,"
142760c2415Smrg " should be %ld", (long int) n+1,
143760c2415Smrg (long int) ret_extent,
144760c2415Smrg (long int) extent[dim]);
145760c2415Smrg
146760c2415Smrg if (extent[dim] <= 0)
147760c2415Smrg zero_sized = 1;
148760c2415Smrg sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
149760c2415Smrg rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
150760c2415Smrg dim++;
151760c2415Smrg }
152760c2415Smrg }
153760c2415Smrg }
154760c2415Smrg else
155760c2415Smrg {
156760c2415Smrg for (n = 0; n < rrank; n++)
157760c2415Smrg {
158760c2415Smrg if (n == along - 1)
159760c2415Smrg {
160760c2415Smrg rdelta = GFC_DESCRIPTOR_STRIDE(ret,n);
161760c2415Smrg }
162760c2415Smrg else
163760c2415Smrg {
164760c2415Smrg count[dim] = 0;
165760c2415Smrg extent[dim] = GFC_DESCRIPTOR_EXTENT(source,dim);
166760c2415Smrg if (extent[dim] <= 0)
167760c2415Smrg zero_sized = 1;
168760c2415Smrg sstride[dim] = GFC_DESCRIPTOR_STRIDE(source,dim);
169760c2415Smrg rstride[dim] = GFC_DESCRIPTOR_STRIDE(ret,n);
170760c2415Smrg dim++;
171760c2415Smrg }
172760c2415Smrg }
173760c2415Smrg }
174760c2415Smrg
175760c2415Smrg if (zero_sized)
176760c2415Smrg return;
177760c2415Smrg
178760c2415Smrg if (sstride[0] == 0)
179760c2415Smrg sstride[0] = 1;
180760c2415Smrg }
181760c2415Smrg sstride0 = sstride[0];
182760c2415Smrg rstride0 = rstride[0];
183760c2415Smrg rptr = ret->base_addr;
184760c2415Smrg sptr = source->base_addr;
185760c2415Smrg
186760c2415Smrg while (sptr)
187760c2415Smrg {
188760c2415Smrg /* Spread this element. */
189760c2415Smrg dest = rptr;
190760c2415Smrg for (n = 0; n < ncopies; n++)
191760c2415Smrg {
192760c2415Smrg *dest = *sptr;
193760c2415Smrg dest += rdelta;
194760c2415Smrg }
195760c2415Smrg /* Advance to the next element. */
196760c2415Smrg sptr += sstride0;
197760c2415Smrg rptr += rstride0;
198760c2415Smrg count[0]++;
199760c2415Smrg n = 0;
200760c2415Smrg while (count[n] == extent[n])
201760c2415Smrg {
202760c2415Smrg /* When we get to the end of a dimension, reset it and increment
203760c2415Smrg the next dimension. */
204760c2415Smrg count[n] = 0;
205760c2415Smrg /* We could precalculate these products, but this is a less
206760c2415Smrg frequently used path so probably not worth it. */
207760c2415Smrg sptr -= sstride[n] * extent[n];
208760c2415Smrg rptr -= rstride[n] * extent[n];
209760c2415Smrg n++;
210760c2415Smrg if (n >= srank)
211760c2415Smrg {
212760c2415Smrg /* Break out of the loop. */
213760c2415Smrg sptr = NULL;
214760c2415Smrg break;
215760c2415Smrg }
216760c2415Smrg else
217760c2415Smrg {
218760c2415Smrg count[n]++;
219760c2415Smrg sptr += sstride[n];
220760c2415Smrg rptr += rstride[n];
221760c2415Smrg }
222760c2415Smrg }
223760c2415Smrg }
224760c2415Smrg }
225760c2415Smrg
226760c2415Smrg /* This version of spread_internal treats the special case of a scalar
227760c2415Smrg source. This is much simpler than the more general case above. */
228760c2415Smrg
229760c2415Smrg void
spread_scalar_c8(gfc_array_c8 * ret,const GFC_COMPLEX_8 * source,const index_type along,const index_type ncopies)230760c2415Smrg spread_scalar_c8 (gfc_array_c8 *ret, const GFC_COMPLEX_8 *source,
231760c2415Smrg const index_type along, const index_type ncopies)
232760c2415Smrg {
233760c2415Smrg GFC_COMPLEX_8 * restrict dest;
234760c2415Smrg index_type stride;
235760c2415Smrg
236760c2415Smrg if (GFC_DESCRIPTOR_RANK (ret) != 1)
237760c2415Smrg runtime_error ("incorrect destination rank in spread()");
238760c2415Smrg
239760c2415Smrg if (along > 1)
240760c2415Smrg runtime_error ("dim outside of rank in spread()");
241760c2415Smrg
242760c2415Smrg if (ret->base_addr == NULL)
243760c2415Smrg {
244760c2415Smrg ret->base_addr = xmallocarray (ncopies, sizeof (GFC_COMPLEX_8));
245760c2415Smrg ret->offset = 0;
246760c2415Smrg GFC_DIMENSION_SET(ret->dim[0], 0, ncopies - 1, 1);
247760c2415Smrg }
248760c2415Smrg else
249760c2415Smrg {
250760c2415Smrg if (ncopies - 1 > (GFC_DESCRIPTOR_EXTENT(ret,0) - 1)
251760c2415Smrg / GFC_DESCRIPTOR_STRIDE(ret,0))
252760c2415Smrg runtime_error ("dim too large in spread()");
253760c2415Smrg }
254760c2415Smrg
255760c2415Smrg dest = ret->base_addr;
256760c2415Smrg stride = GFC_DESCRIPTOR_STRIDE(ret,0);
257760c2415Smrg
258760c2415Smrg for (index_type n = 0; n < ncopies; n++)
259760c2415Smrg {
260760c2415Smrg *dest = *source;
261760c2415Smrg dest += stride;
262760c2415Smrg }
263760c2415Smrg }
264760c2415Smrg
265760c2415Smrg #endif
266760c2415Smrg
267