1627f7eb2Smrg /* Helper function for cshift functions.
2*4c3eb207Smrg Copyright (C) 2008-2020 Free Software Foundation, Inc.
3627f7eb2Smrg Contributed by Thomas Koenig <tkoenig@gcc.gnu.org>
4627f7eb2Smrg
5627f7eb2Smrg This file is part of the GNU Fortran runtime library (libgfortran).
6627f7eb2Smrg
7627f7eb2Smrg Libgfortran is free software; you can redistribute it and/or
8627f7eb2Smrg modify it under the terms of the GNU General Public
9627f7eb2Smrg License as published by the Free Software Foundation; either
10627f7eb2Smrg version 3 of the License, or (at your option) any later version.
11627f7eb2Smrg
12627f7eb2Smrg Libgfortran is distributed in the hope that it will be useful,
13627f7eb2Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
14627f7eb2Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15627f7eb2Smrg GNU General Public License for more details.
16627f7eb2Smrg
17627f7eb2Smrg Under Section 7 of GPL version 3, you are granted additional
18627f7eb2Smrg permissions described in the GCC Runtime Library Exception, version
19627f7eb2Smrg 3.1, as published by the Free Software Foundation.
20627f7eb2Smrg
21627f7eb2Smrg You should have received a copy of the GNU General Public License and
22627f7eb2Smrg a copy of the GCC Runtime Library Exception along with this program;
23627f7eb2Smrg see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24627f7eb2Smrg <http://www.gnu.org/licenses/>. */
25627f7eb2Smrg
26627f7eb2Smrg #include "libgfortran.h"
27627f7eb2Smrg #include <string.h>
28627f7eb2Smrg
29627f7eb2Smrg
30627f7eb2Smrg #if defined (HAVE_GFC_REAL_8)
31627f7eb2Smrg
32627f7eb2Smrg void
cshift0_r8(gfc_array_r8 * ret,const gfc_array_r8 * array,ptrdiff_t shift,int which)33627f7eb2Smrg cshift0_r8 (gfc_array_r8 *ret, const gfc_array_r8 *array, ptrdiff_t shift,
34627f7eb2Smrg int which)
35627f7eb2Smrg {
36627f7eb2Smrg /* r.* indicates the return array. */
37627f7eb2Smrg index_type rstride[GFC_MAX_DIMENSIONS];
38627f7eb2Smrg index_type rstride0;
39627f7eb2Smrg index_type roffset;
40627f7eb2Smrg GFC_REAL_8 *rptr;
41627f7eb2Smrg
42627f7eb2Smrg /* s.* indicates the source array. */
43627f7eb2Smrg index_type sstride[GFC_MAX_DIMENSIONS];
44627f7eb2Smrg index_type sstride0;
45627f7eb2Smrg index_type soffset;
46627f7eb2Smrg const GFC_REAL_8 *sptr;
47627f7eb2Smrg
48627f7eb2Smrg index_type count[GFC_MAX_DIMENSIONS];
49627f7eb2Smrg index_type extent[GFC_MAX_DIMENSIONS];
50627f7eb2Smrg index_type dim;
51627f7eb2Smrg index_type len;
52627f7eb2Smrg index_type n;
53627f7eb2Smrg
54627f7eb2Smrg bool do_blocked;
55627f7eb2Smrg index_type r_ex, a_ex;
56627f7eb2Smrg
57627f7eb2Smrg which = which - 1;
58627f7eb2Smrg sstride[0] = 0;
59627f7eb2Smrg rstride[0] = 0;
60627f7eb2Smrg
61627f7eb2Smrg extent[0] = 1;
62627f7eb2Smrg count[0] = 0;
63627f7eb2Smrg n = 0;
64627f7eb2Smrg /* Initialized for avoiding compiler warnings. */
65627f7eb2Smrg roffset = 1;
66627f7eb2Smrg soffset = 1;
67627f7eb2Smrg len = 0;
68627f7eb2Smrg
69627f7eb2Smrg r_ex = 1;
70627f7eb2Smrg a_ex = 1;
71627f7eb2Smrg
72627f7eb2Smrg if (which > 0)
73627f7eb2Smrg {
74627f7eb2Smrg /* Test if both ret and array are contiguous. */
75627f7eb2Smrg do_blocked = true;
76627f7eb2Smrg dim = GFC_DESCRIPTOR_RANK (array);
77627f7eb2Smrg for (n = 0; n < dim; n ++)
78627f7eb2Smrg {
79627f7eb2Smrg index_type rs, as;
80627f7eb2Smrg rs = GFC_DESCRIPTOR_STRIDE (ret, n);
81627f7eb2Smrg if (rs != r_ex)
82627f7eb2Smrg {
83627f7eb2Smrg do_blocked = false;
84627f7eb2Smrg break;
85627f7eb2Smrg }
86627f7eb2Smrg as = GFC_DESCRIPTOR_STRIDE (array, n);
87627f7eb2Smrg if (as != a_ex)
88627f7eb2Smrg {
89627f7eb2Smrg do_blocked = false;
90627f7eb2Smrg break;
91627f7eb2Smrg }
92627f7eb2Smrg r_ex *= GFC_DESCRIPTOR_EXTENT (ret, n);
93627f7eb2Smrg a_ex *= GFC_DESCRIPTOR_EXTENT (array, n);
94627f7eb2Smrg }
95627f7eb2Smrg }
96627f7eb2Smrg else
97627f7eb2Smrg do_blocked = false;
98627f7eb2Smrg
99627f7eb2Smrg n = 0;
100627f7eb2Smrg
101627f7eb2Smrg if (do_blocked)
102627f7eb2Smrg {
103627f7eb2Smrg /* For contiguous arrays, use the relationship that
104627f7eb2Smrg
105627f7eb2Smrg dimension(n1,n2,n3) :: a, b
106627f7eb2Smrg b = cshift(a,sh,3)
107627f7eb2Smrg
108627f7eb2Smrg can be dealt with as if
109627f7eb2Smrg
110627f7eb2Smrg dimension(n1*n2*n3) :: an, bn
111627f7eb2Smrg bn = cshift(a,sh*n1*n2,1)
112627f7eb2Smrg
113627f7eb2Smrg we can used a more blocked algorithm for dim>1. */
114627f7eb2Smrg sstride[0] = 1;
115627f7eb2Smrg rstride[0] = 1;
116627f7eb2Smrg roffset = 1;
117627f7eb2Smrg soffset = 1;
118627f7eb2Smrg len = GFC_DESCRIPTOR_STRIDE(array, which)
119627f7eb2Smrg * GFC_DESCRIPTOR_EXTENT(array, which);
120627f7eb2Smrg shift *= GFC_DESCRIPTOR_STRIDE(array, which);
121627f7eb2Smrg for (dim = which + 1; dim < GFC_DESCRIPTOR_RANK (array); dim++)
122627f7eb2Smrg {
123627f7eb2Smrg count[n] = 0;
124627f7eb2Smrg extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
125627f7eb2Smrg rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
126627f7eb2Smrg sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
127627f7eb2Smrg n++;
128627f7eb2Smrg }
129627f7eb2Smrg dim = GFC_DESCRIPTOR_RANK (array) - which;
130627f7eb2Smrg }
131627f7eb2Smrg else
132627f7eb2Smrg {
133627f7eb2Smrg for (dim = 0; dim < GFC_DESCRIPTOR_RANK (array); dim++)
134627f7eb2Smrg {
135627f7eb2Smrg if (dim == which)
136627f7eb2Smrg {
137627f7eb2Smrg roffset = GFC_DESCRIPTOR_STRIDE(ret,dim);
138627f7eb2Smrg if (roffset == 0)
139627f7eb2Smrg roffset = 1;
140627f7eb2Smrg soffset = GFC_DESCRIPTOR_STRIDE(array,dim);
141627f7eb2Smrg if (soffset == 0)
142627f7eb2Smrg soffset = 1;
143627f7eb2Smrg len = GFC_DESCRIPTOR_EXTENT(array,dim);
144627f7eb2Smrg }
145627f7eb2Smrg else
146627f7eb2Smrg {
147627f7eb2Smrg count[n] = 0;
148627f7eb2Smrg extent[n] = GFC_DESCRIPTOR_EXTENT(array,dim);
149627f7eb2Smrg rstride[n] = GFC_DESCRIPTOR_STRIDE(ret,dim);
150627f7eb2Smrg sstride[n] = GFC_DESCRIPTOR_STRIDE(array,dim);
151627f7eb2Smrg n++;
152627f7eb2Smrg }
153627f7eb2Smrg }
154627f7eb2Smrg if (sstride[0] == 0)
155627f7eb2Smrg sstride[0] = 1;
156627f7eb2Smrg if (rstride[0] == 0)
157627f7eb2Smrg rstride[0] = 1;
158627f7eb2Smrg
159627f7eb2Smrg dim = GFC_DESCRIPTOR_RANK (array);
160627f7eb2Smrg }
161627f7eb2Smrg
162627f7eb2Smrg rstride0 = rstride[0];
163627f7eb2Smrg sstride0 = sstride[0];
164627f7eb2Smrg rptr = ret->base_addr;
165627f7eb2Smrg sptr = array->base_addr;
166627f7eb2Smrg
167627f7eb2Smrg /* Avoid the costly modulo for trivially in-bound shifts. */
168627f7eb2Smrg if (shift < 0 || shift >= len)
169627f7eb2Smrg {
170627f7eb2Smrg shift = len == 0 ? 0 : shift % (ptrdiff_t)len;
171627f7eb2Smrg if (shift < 0)
172627f7eb2Smrg shift += len;
173627f7eb2Smrg }
174627f7eb2Smrg
175627f7eb2Smrg while (rptr)
176627f7eb2Smrg {
177627f7eb2Smrg /* Do the shift for this dimension. */
178627f7eb2Smrg
179627f7eb2Smrg /* If elements are contiguous, perform the operation
180627f7eb2Smrg in two block moves. */
181627f7eb2Smrg if (soffset == 1 && roffset == 1)
182627f7eb2Smrg {
183627f7eb2Smrg size_t len1 = shift * sizeof (GFC_REAL_8);
184627f7eb2Smrg size_t len2 = (len - shift) * sizeof (GFC_REAL_8);
185627f7eb2Smrg memcpy (rptr, sptr + shift, len2);
186627f7eb2Smrg memcpy (rptr + (len - shift), sptr, len1);
187627f7eb2Smrg }
188627f7eb2Smrg else
189627f7eb2Smrg {
190627f7eb2Smrg /* Otherwise, we will have to perform the copy one element at
191627f7eb2Smrg a time. */
192627f7eb2Smrg GFC_REAL_8 *dest = rptr;
193627f7eb2Smrg const GFC_REAL_8 *src = &sptr[shift * soffset];
194627f7eb2Smrg
195627f7eb2Smrg for (n = 0; n < len - shift; n++)
196627f7eb2Smrg {
197627f7eb2Smrg *dest = *src;
198627f7eb2Smrg dest += roffset;
199627f7eb2Smrg src += soffset;
200627f7eb2Smrg }
201627f7eb2Smrg for (src = sptr, n = 0; n < shift; n++)
202627f7eb2Smrg {
203627f7eb2Smrg *dest = *src;
204627f7eb2Smrg dest += roffset;
205627f7eb2Smrg src += soffset;
206627f7eb2Smrg }
207627f7eb2Smrg }
208627f7eb2Smrg
209627f7eb2Smrg /* Advance to the next section. */
210627f7eb2Smrg rptr += rstride0;
211627f7eb2Smrg sptr += sstride0;
212627f7eb2Smrg count[0]++;
213627f7eb2Smrg n = 0;
214627f7eb2Smrg while (count[n] == extent[n])
215627f7eb2Smrg {
216627f7eb2Smrg /* When we get to the end of a dimension, reset it and increment
217627f7eb2Smrg the next dimension. */
218627f7eb2Smrg count[n] = 0;
219627f7eb2Smrg /* We could precalculate these products, but this is a less
220627f7eb2Smrg frequently used path so probably not worth it. */
221627f7eb2Smrg rptr -= rstride[n] * extent[n];
222627f7eb2Smrg sptr -= sstride[n] * extent[n];
223627f7eb2Smrg n++;
224627f7eb2Smrg if (n >= dim - 1)
225627f7eb2Smrg {
226627f7eb2Smrg /* Break out of the loop. */
227627f7eb2Smrg rptr = NULL;
228627f7eb2Smrg break;
229627f7eb2Smrg }
230627f7eb2Smrg else
231627f7eb2Smrg {
232627f7eb2Smrg count[n]++;
233627f7eb2Smrg rptr += rstride[n];
234627f7eb2Smrg sptr += sstride[n];
235627f7eb2Smrg }
236627f7eb2Smrg }
237627f7eb2Smrg }
238627f7eb2Smrg
239627f7eb2Smrg return;
240627f7eb2Smrg }
241627f7eb2Smrg
242627f7eb2Smrg #endif
243