1 /*
2 * Copyright (c) 1995-2018, NVIDIA CORPORATION. All rights reserved.
3 *
4 * Licensed under the Apache License, Version 2.0 (the "License");
5 * you may not use this file except in compliance with the License.
6 * You may obtain a copy of the License at
7 *
8 * http://www.apache.org/licenses/LICENSE-2.0
9 *
10 * Unless required by applicable law or agreed to in writing, software
11 * distributed under the License is distributed on an "AS IS" BASIS,
12 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 * See the License for the specific language governing permissions and
14 * limitations under the License.
15 *
16 */
17
18 /* clang-format off */
19
20 #include "stdioInterf.h"
21 #include "fioMacros.h"
22
23 extern void (*__fort_scalar_copy[__NTYPES])(void *rp, void *sp, int len);
24
25 /* advance index n elements and return the remaining extent in the
26 first dimension from that point. When the end of the array is
27 reached, index is reset to the first element and 0 is returned. */
28
I8(advance)29 static int I8(advance)(F90_Desc *d, __INT_T *index, __INT_T n)
30 {
31 __INT_T i, r;
32
33 index[0] += n;
34 if (index[0] <= DIM_UBOUND_G(d, 0))
35 return DIM_UBOUND_G(d, 0) - index[0] + 1;
36 else if (index[0] > DIM_UBOUND_G(d, 0) + 1)
37 __fort_abort("RESHAPE: internal error, advance past ubound");
38 else
39 index[0] = F90_DIM_LBOUND_G(d, 0);
40 r = F90_RANK_G(d);
41 for (i = 1; i < r; ++i) {
42 index[i]++;
43 if (index[i] <= DIM_UBOUND_G(d, i))
44 return DIM_UBOUND_G(d, 0) - index[0] + 1;
45 else
46 index[i] = F90_DIM_LBOUND_G(d, i);
47 }
48 return 0;
49 }
50
51 /* note: dimensions in order vector are zero-based. */
52
I8(advance_permuted)53 static int I8(advance_permuted)(F90_Desc *d, __INT_T *index, int *order,
54 __INT_T n)
55 {
56 int j, k;
57 __INT_T i, r;
58
59 k = order[0];
60 index[k] += n;
61 if (index[k] <= DIM_UBOUND_G(d, k))
62 return DIM_UBOUND_G(d, k) - index[k] + 1;
63 else if (index[k] > DIM_UBOUND_G(d, k) + 1)
64 __fort_abort("RESHAPE: internal error, advance past ubound");
65 else
66 index[k] = F90_DIM_LBOUND_G(d, k);
67 r = F90_RANK_G(d);
68 for (i = 1; i < r; i++) {
69 j = order[i];
70 index[j]++;
71 if (index[j] <= DIM_UBOUND_G(d, j))
72 return DIM_UBOUND_G(d, k) - index[k] + 1;
73 else
74 index[j] = F90_DIM_LBOUND_G(d, j);
75 }
76 return 0;
77 }
78
79 /* reshape intrinsic */
80
ENTFTN(RESHAPE,reshape)81 void ENTFTN(RESHAPE, reshape)(char *resb, /* result base */
82 char *srcb, /* source base */
83 char *shpb, /* shape base */
84 char *padb, /* pad base */
85 char *ordb, /* order base */
86 F90_Desc *resd, /* result descriptor */
87 F90_Desc *srcd, /* source descriptor */
88 F90_Desc *shpd, /* shape descriptor */
89 F90_Desc *padd, /* pad descriptor */
90 F90_Desc *ordd) /* order descriptor */
91 {
92 __INT_T resx[MAXDIMS];
93 __INT_T srcx[MAXDIMS];
94 __INT_T padx[MAXDIMS];
95 int shape[MAXDIMS];
96 int order[MAXDIMS];
97 DECL_HDR_VARS(fromd);
98 DECL_HDR_VARS(tod);
99 char *fromb, *tob;
100 chdr *ch;
101 __INT_T more_res, more_src, more_pad, n;
102 int i, j, k, m, r;
103
104 #if defined(DEBUG)
105 if (resd == NULL || F90_TAG_G(resd) != __DESC)
106 __fort_abort("RESHAPE: invalid result descriptor");
107 if (srcd == NULL || F90_TAG_G(srcd) != __DESC)
108 __fort_abort("RESHAPE: invalid SOURCE descriptor");
109 if (shpd == NULL || F90_TAG_G(shpd) != __DESC)
110 __fort_abort("RESHAPE: invalid SHAPE descriptor");
111 if (padd == NULL || F90_TAG_G(padd) != __DESC && F90_TAG_G(padd) != __NONE)
112 __fort_abort("RESHAPE: invalid PAD descriptor");
113 if (ordd == NULL || F90_TAG_G(ordd) != __DESC && F90_TAG_G(ordd) != __NONE)
114 __fort_abort("RESHAPE: invalid ORDER descriptor");
115 #endif
116
117 if (F90_KIND_G(resd) != F90_KIND_G(srcd) ||
118 F90_LEN_G(resd) != F90_LEN_G(srcd))
119 __fort_abort("RESHAPE: result type != SOURCE type");
120 if (F90_TAG_G(padd) == __DESC && (F90_KIND_G(padd) != F90_KIND_G(srcd) ||
121 F90_LEN_G(padd) != F90_LEN_G(srcd)))
122 __fort_abort("RESHAPE: PAD type != SOURCE type");
123
124 /* don't really need the shape vector because the shape is already
125 set in the result descriptor, but check its validity anyway */
126
127 if (F90_RANK_G(shpd) <= 0)
128 __fort_abort("RESHAPE: invalid SHAPE argument");
129
130 r = DIM_UBOUND_G(shpd, 0) - F90_DIM_LBOUND_G(shpd, 0) + 1;
131 if (r < 0 || r > MAXDIMS || r != F90_RANK_G(resd))
132 __fort_abort("RESHAPE: invalid SHAPE argument");
133
134 I8(__fort_fetch_int_vector)(shpb, shpd, shape, r);
135 for (i = r; --i >= 0;) {
136 if (shape[i] < 0)
137 __fort_abort("RESHAPE: invalid SHAPE argument");
138 }
139
140 /* get the order vector */
141
142 if (F90_TAG_G(ordd) == __DESC) {
143 I8(__fort_fetch_int_vector)(ordb, ordd, order, r);
144 m = 0;
145 for (i = r; --i >= 0;) {
146 if (order[i] < 1 || order[i] > r)
147 __fort_abort("RESHAPE: invalid ORDER argument");
148 --order[i]; /* zero-based dimension number */
149 m |= 1 << order[i];
150 }
151 if (m != ~(-1 << r))
152 __fort_abort("RESHAPE: invalid ORDER argument");
153 } else { /* absent */
154 for (i = r; --i >= 0;)
155 order[i] = i;
156 }
157
158 /* initialize indices and first column extents */
159
160 if (F90_GSIZE_G(resd) <= 0)
161 return;
162 for (i = r; --i >= 0;)
163 resx[i] = F90_DIM_LBOUND_G(resd, i);
164 k = order[0];
165 more_res = DIM_UBOUND_G(resd, k) - F90_DIM_LBOUND_G(resd, k) + 1;
166
167 if (F90_GSIZE_G(srcd) > 0) {
168 for (i = F90_RANK_G(srcd); --i >= 0;)
169 srcx[i] = F90_DIM_LBOUND_G(srcd, i);
170 more_src = DIM_UBOUND_G(srcd, 0) - F90_DIM_LBOUND_G(srcd, 0) + 1;
171 } else
172 more_src = 0;
173
174 if (F90_TAG_G(padd) == __DESC && F90_GSIZE_G(padd) > 0) {
175 for (i = F90_RANK_G(padd); --i >= 0;)
176 padx[i] = F90_DIM_LBOUND_G(padd, i);
177 more_pad = DIM_UBOUND_G(padd, 0) - F90_DIM_LBOUND_G(padd, 0) + 1;
178 } else
179 more_pad = 0;
180
181 /* loop -- transfer matching column vector sections and advance
182 indices until result array is filled */
183
184 while (more_res) {
185
186 if (more_src) {
187 n = Min(more_src, more_res);
188
189 __DIST_INIT_SECTION(fromd, 1, srcd);
190 I8(__fort_set_section)(fromd, 1, srcd, 1, srcx[0], srcx[0] + n - 1, 1);
191 for (i = 1; i < F90_RANK_G(srcd); ++i)
192 I8(__fort_set_single)(fromd, srcd, i + 1, srcx[i], __SCALAR);
193 I8(__fort_finish_section)(fromd);
194 fromb = srcb;
195
196 more_src = I8(advance)(srcd, srcx, n);
197 } else if (more_pad) {
198 n = Min(more_pad, more_res);
199
200 fromb = padb;
201 __DIST_INIT_SECTION(fromd, 1, padd);
202 I8(__fort_set_section)(fromd, 1, padd, 1, padx[0], padx[0] + n - 1, 1);
203 for (i = 1; i < F90_RANK_G(padd); ++i)
204 I8(__fort_set_single)(fromd, padd, i + 1, padx[i], __SCALAR);
205 I8(__fort_finish_section)(fromd);
206
207 more_pad = I8(advance)(padd, padx, n);
208 if (!more_pad) /* start over if end reached */
209 more_pad = DIM_UBOUND_G(padd, 0) - F90_DIM_LBOUND_G(padd, 0) + 1;
210 } else
211 __fort_abort("RESHAPE: not enough elements in SOURCE array");
212
213 __DIST_INIT_SECTION(tod, 1, resd);
214 I8(__fort_set_section)(tod, 1, resd, k + 1, resx[k], resx[k] + n - 1, 1);
215 for (i = 1; i < F90_RANK_G(resd); ++i) {
216 j = order[i];
217 I8(__fort_set_single)(tod, resd, j + 1, resx[j], __SCALAR);
218 }
219 I8(__fort_finish_section)(tod);
220
221 fromb += DIST_SCOFF_G(fromd) * F90_LEN_G(fromd);
222 tob = resb + DIST_SCOFF_G(tod) * F90_LEN_G(tod);
223
224 ch = I8(__fort_copy)(tob, fromb, tod, fromd, NULL);
225 __fort_doit(ch);
226 __fort_frechn(ch);
227
228 more_res = I8(advance_permuted)(resd, resx, order, n);
229 }
230 }
231
ENTFTN(RESHAPECA,reshapeca)232 void ENTFTN(RESHAPECA, reshapeca)(DCHAR(resb), /* result char base */
233 DCHAR(srcb), /* source char base */
234 char *shpb, /* shape base */
235 DCHAR(padb), /* pad char base */
236 char *ordb, /* order base */
237 F90_Desc *resd, /* result descriptor */
238 F90_Desc *srcd, /* source descriptor */
239 F90_Desc *shpd, /* shape descriptor */
240 F90_Desc *padd, /* pad descriptor */
241 F90_Desc *ordd /* order descriptor */
242 DCLEN64(resb) /* result char len */
243 DCLEN64(srcb) /* source char len */
244 DCLEN64(padb)) /* pad char len */
245 {
246 ENTFTN(RESHAPE, reshape)
247 (CADR(resb), CADR(srcb), shpb, CADR(padb), ordb, resd, srcd, shpd, padd,
248 ordd);
249 }
250 /* 32 bit CLEN version */
ENTFTN(RESHAPEC,reshapec)251 void ENTFTN(RESHAPEC, reshapec)(DCHAR(resb), /* result char base */
252 DCHAR(srcb), /* source char base */
253 char *shpb, /* shape base */
254 DCHAR(padb), /* pad char base */
255 char *ordb, /* order base */
256 F90_Desc *resd, /* result descriptor */
257 F90_Desc *srcd, /* source descriptor */
258 F90_Desc *shpd, /* shape descriptor */
259 F90_Desc *padd, /* pad descriptor */
260 F90_Desc *ordd /* order descriptor */
261 DCLEN(resb) /* result char len */
262 DCLEN(srcb) /* source char len */
263 DCLEN(padb)) /* pad char len */
264 {
265 ENTFTN(RESHAPECA, reshapeca)(CADR(resb), CADR(srcb), shpb, CADR(padb), ordb,
266 resd, srcd, shpd, padd, ordd, (__CLEN_T)CLEN(resb),
267 (__CLEN_T)CLEN(srcb), (__CLEN_T)CLEN(padb));
268 }
269