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 #include "fort_vars.h"
24
I8(eoshift_scalar)25 static void I8(eoshift_scalar)(char *rb, /* result base */
26 char *ab, /* array base */
27 __INT_T shift_amt, /* shift amount */
28 char *bb, /* boundary base */
29 __INT_T shift_dim, /* shift dimension */
30 F90_Desc *rs, /* result descriptor */
31 F90_Desc *as, /* array descriptor */
32 F90_Desc *rc, /* result subsection descriptor */
33 F90_Desc *ac, /* array subsection descriptor */
34 __INT_T sub_dim) /* subsection dimension */
35 {
36 chdr *c;
37 char *ap, *rp;
38 DECL_DIM_PTRS(asd);
39 DECL_DIM_PTRS(rsd);
40 __INT_T aflags, albase, apbase, arepli, ascoff;
41 __INT_T rflags, rlbase, rpbase, rrepli, rscoff;
42 __INT_T aolb[MAXDIMS], aoub[MAXDIMS];
43 __INT_T rolb[MAXDIMS], roub[MAXDIMS];
44 __INT_T extent, i, sabs;
45
46 #if defined(DEBUG)
47 if (__fort_test & DEBUG_EOSH) {
48 printf("%d eoshift_scalar shift=%d boundary=", GET_DIST_LCPU, shift_amt);
49 __fort_print_scalar(bb, F90_KIND_G(rs));
50 printf(" dim=%d\n", shift_dim);
51 }
52 #endif
53
54 SET_DIM_PTRS(rsd, rs, shift_dim - 1);
55 SET_DIM_PTRS(asd, as, shift_dim - 1);
56
57 extent = F90_DPTR_EXTENT_G(asd);
58 if (extent < 0)
59 return;
60
61 /* save descriptor fields affected by set/finish_section */
62
63 aflags = F90_FLAGS_G(ac);
64 albase = F90_LBASE_G(ac);
65 apbase = DIST_PBASE_G(ac);
66 arepli = DIST_REPLICATED_G(ac);
67 ascoff = DIST_SCOFF_G(ac);
68 for (i = F90_RANK_G(ac); --i >= 0;) {
69 aolb[i] = DIST_DIM_OLB_G(ac, i);
70 aoub[i] = DIST_DIM_OUB_G(ac, i);
71 }
72 rflags = F90_FLAGS_G(rc);
73 rlbase = F90_LBASE_G(rc);
74 rpbase = DIST_PBASE_G(rc);
75 rrepli = DIST_REPLICATED_G(rc);
76 rscoff = DIST_SCOFF_G(rc);
77 for (i = F90_RANK_G(rc); --i >= 0;) {
78 rolb[i] = DIST_DIM_OLB_G(rc, i);
79 roub[i] = DIST_DIM_OUB_G(rc, i);
80 }
81
82 /* copy directly if shift amount is zero */
83
84 if (shift_amt == 0) {
85 I8(__fort_set_section)(rc, sub_dim, rs, shift_dim,
86 F90_DPTR_LBOUND_G(rsd), DPTR_UBOUND_G(rsd), 1);
87 I8(__fort_finish_section)(rc);
88 I8(__fort_set_section)(ac, sub_dim, as, shift_dim,
89 F90_DPTR_LBOUND_G(asd), DPTR_UBOUND_G(asd), 1);
90 I8(__fort_finish_section)(ac);
91
92 /* adjust base addresses for scalar subscripts and copy */
93
94 rp = rb + DIST_SCOFF_G(rc) * F90_LEN_G(rc);
95 ap = ab + DIST_SCOFF_G(ac) * F90_LEN_G(ac);
96 c = I8(__fort_copy)(rp, ap, rc, ac, NULL);
97 __fort_doit(c);
98 __fort_frechn(c);
99
100 /* restore descriptor fields */
101
102 F90_FLAGS_P(ac, aflags);
103 F90_LBASE_P(ac, albase);
104 DIST_PBASE_P(ac, apbase);
105 DIST_REPLICATED_P(ac, arepli);
106 DIST_SCOFF_P(ac, ascoff);
107 for (i = F90_RANK_G(ac); --i >= 0;) {
108 DIST_DIM_OLB_P(ac, i, aolb[i]);
109 DIST_DIM_OUB_P(ac, i, aoub[i]);
110 }
111 DIST_CACHED_P(ac, 0);
112
113 F90_FLAGS_P(rc, rflags);
114 F90_LBASE_P(rc, rlbase);
115 DIST_PBASE_P(rc, rpbase);
116 DIST_REPLICATED_P(rc, rrepli);
117 DIST_SCOFF_P(rc, rscoff);
118 for (i = F90_RANK_G(rc); --i >= 0;) {
119 DIST_DIM_OLB_P(rc, i, rolb[i]);
120 DIST_DIM_OUB_P(rc, i, roub[i]);
121 }
122 DIST_CACHED_P(rc, 0);
123 return;
124 }
125
126 /* if the absolute shift amount is greater than or equal to the
127 extent, just fill the result section with boundary values */
128
129 sabs = Abs(shift_amt);
130 if (sabs >= extent) {
131 I8(__fort_set_section)(rc, sub_dim, rs, shift_dim,
132 F90_DPTR_LBOUND_G(rsd), DPTR_UBOUND_G(rsd), 1);
133 I8(__fort_finish_section)(rc);
134
135 I8(__fort_fills)(rb, rc, bb);
136
137 /* restore descriptor fields */
138
139 F90_FLAGS_P(rc, rflags);
140 F90_LBASE_P(rc, rlbase);
141 DIST_PBASE_P(rc, rpbase);
142 DIST_REPLICATED_P(rc, rrepli);
143 DIST_SCOFF_P(rc, rscoff);
144 DIST_CACHED_P(rc, 0);
145 for (i = F90_RANK_G(rc); --i >= 0;) {
146 DIST_DIM_OLB_P(rc, i, rolb[i]);
147 DIST_DIM_OUB_P(rc, i, roub[i]);
148 }
149 return;
150 }
151
152 if (shift_amt < 0)
153 sabs = extent - sabs;
154
155 /* lower part of result */
156
157 I8(__fort_set_section)(rc, sub_dim, rs, shift_dim,
158 F90_DPTR_LBOUND_G(rsd), DPTR_UBOUND_G(rsd) - sabs, 1);
159
160 I8(__fort_finish_section)(rc);
161
162 if (shift_amt > 0) {
163
164 I8(__fort_set_section)(ac, sub_dim, as, shift_dim,
165 F90_DPTR_LBOUND_G(asd) + sabs,
166 DPTR_UBOUND_G(asd), 1);
167
168 I8(__fort_finish_section)(ac);
169 rp = rb + DIST_SCOFF_G(rc) * F90_LEN_G(rc);
170 ap = ab + DIST_SCOFF_G(ac) * F90_LEN_G(ac);
171 c = I8(__fort_copy)(rp, ap, rc, ac, NULL);
172 } else
173 I8(__fort_fills)(rb, rc, bb);
174
175 /* restore descriptor fields */
176
177 F90_FLAGS_P(ac, aflags);
178 F90_LBASE_P(ac, albase);
179 DIST_PBASE_P(ac, apbase);
180 DIST_REPLICATED_P(ac, arepli);
181 DIST_SCOFF_P(ac, ascoff);
182 DIST_CACHED_P(ac, 0);
183 for (i = F90_RANK_G(ac); --i >= 0;) {
184 DIST_DIM_OLB_P(ac, i, aolb[i]);
185 DIST_DIM_OUB_P(ac, i, aoub[i]);
186 }
187 F90_FLAGS_P(rc, rflags);
188 F90_LBASE_P(rc, rlbase);
189 DIST_PBASE_P(rc, rpbase);
190 DIST_REPLICATED_P(rc, rrepli);
191 DIST_SCOFF_P(rc, rscoff);
192 for (i = F90_RANK_G(rc); --i >= 0;) {
193 DIST_DIM_OLB_P(rc, i, rolb[i]);
194 DIST_DIM_OUB_P(rc, i, roub[i]);
195 }
196 DIST_CACHED_P(rc, 0);
197
198 /* upper part of result */
199
200 I8(__fort_set_section)(rc, sub_dim, rs, shift_dim,
201 F90_DPTR_LBOUND_G(rsd) + (extent - sabs),
202 DPTR_UBOUND_G(rsd), 1);
203
204 I8(__fort_finish_section)(rc);
205
206 if (shift_amt < 0) {
207
208 I8(__fort_set_section)(ac, sub_dim, as, shift_dim,
209 F90_DPTR_LBOUND_G(asd),
210 DPTR_UBOUND_G(asd) - (extent - sabs), 1);
211
212 I8(__fort_finish_section)(ac);
213 rp = rb + DIST_SCOFF_G(rc) * F90_LEN_G(rc);
214 ap = ab + DIST_SCOFF_G(ac) * F90_LEN_G(ac);
215 c = I8(__fort_copy)(rp, ap, rc, ac, NULL);
216 } else
217 I8(__fort_fills)(rb, rc, bb);
218
219 __fort_doit(c);
220 __fort_frechn(c);
221
222 /* restore descriptor fields */
223
224 F90_FLAGS_P(ac, aflags);
225 F90_LBASE_P(ac, albase);
226 DIST_PBASE_P(ac, apbase);
227 DIST_REPLICATED_P(ac, arepli);
228 DIST_SCOFF_P(ac, ascoff);
229 for (i = F90_RANK_G(ac); --i >= 0;) {
230 DIST_DIM_OLB_P(ac, i, aolb[i]);
231 DIST_DIM_OUB_P(ac, i, aoub[i]);
232 }
233 DIST_CACHED_P(ac, 0);
234
235 F90_FLAGS_P(rc, rflags);
236 F90_LBASE_P(rc, rlbase);
237 DIST_PBASE_P(rc, rpbase);
238 DIST_REPLICATED_P(rc, rrepli);
239 DIST_SCOFF_P(rc, rscoff);
240 for (i = F90_RANK_G(rc); --i >= 0;) {
241 DIST_DIM_OLB_P(rc, i, rolb[i]);
242 DIST_DIM_OUB_P(rc, i, roub[i]);
243 }
244 DIST_CACHED_P(rc, 0);
245 }
246
I8(eoshift_loop)247 static void I8(eoshift_loop)(char *rb, /* result base */
248 char *ab, /* array base */
249 __INT_T *sb, /* shift base */
250 char *bb, /* boundary base */
251 __INT_T shift_dim, /* dimension to shift */
252 F90_Desc *rs, /* result descriptor */
253 F90_Desc *as, /* array descriptor */
254 F90_Desc *ss, /* shift descriptor */
255 F90_Desc *bs, /* boundary descriptor */
256 F90_Desc *rc, /* result subsection descriptor */
257 F90_Desc *ac, /* array subsection descriptor */
258 __INT_T soff, /* shift offset */
259 __INT_T boff, /* boundary offset */
260 __INT_T loop_dim) /* loop dim */
261 {
262 DECL_DIM_PTRS(asd);
263 DECL_DIM_PTRS(bsd);
264 DECL_DIM_PTRS(rsd);
265 DECL_DIM_PTRS(ssd);
266 __INT_T aflags, albase, apbase, arepli, ascoff;
267 __INT_T rflags, rlbase, rpbase, rrepli, rscoff;
268 __INT_T ai, array_dim, bstr, l, ri, sstr;
269
270 /* shift rank = array rank - 1*/
271
272 array_dim = loop_dim;
273 if (array_dim >= shift_dim)
274 ++array_dim;
275
276 SET_DIM_PTRS(rsd, rs, array_dim - 1);
277 ri = F90_DPTR_LBOUND_G(rsd);
278
279 SET_DIM_PTRS(asd, as, array_dim - 1);
280 ai = F90_DPTR_LBOUND_G(asd);
281
282 if (F90_TAG_G(ss) == __DESC) {
283 SET_DIM_PTRS(ssd, ss, loop_dim - 1);
284 sstr = F90_DPTR_SSTRIDE_G(ssd) * F90_DPTR_LSTRIDE_G(ssd);
285 soff += (F90_DPTR_SSTRIDE_G(ssd) * F90_DPTR_LBOUND_G(ssd) +
286 F90_DPTR_SOFFSET_G(ssd)) *
287 F90_DPTR_LSTRIDE_G(ssd);
288 } else
289 sstr = soff = 0;
290
291 if (F90_TAG_G(bs) == __DESC) {
292 SET_DIM_PTRS(bsd, bs, loop_dim - 1);
293 bstr = F90_DPTR_SSTRIDE_G(bsd) * F90_DPTR_LSTRIDE_G(bsd);
294 boff += (F90_DPTR_SSTRIDE_G(bsd) * F90_DPTR_LBOUND_G(bsd) +
295 F90_DPTR_SOFFSET_G(bsd)) *
296 F90_DPTR_LSTRIDE_G(bsd);
297 } else
298 bstr = boff = 0;
299
300 /* save descriptor fields affected by set_single */
301
302 aflags = F90_FLAGS_G(ac);
303 albase = F90_LBASE_G(ac);
304 apbase = DIST_PBASE_G(ac);
305 arepli = DIST_REPLICATED_G(ac);
306 ascoff = DIST_SCOFF_G(ac);
307
308 rflags = F90_FLAGS_G(rc);
309 rlbase = F90_LBASE_G(rc);
310 rpbase = DIST_PBASE_G(rc);
311 rrepli = DIST_REPLICATED_G(rc);
312 rscoff = DIST_SCOFF_G(rc);
313
314 for (; ri <= DPTR_UBOUND_G(rsd); ++ri, ++ai, soff += sstr, boff += bstr) {
315 I8(__fort_set_single)(rc, rs, array_dim, ri, __SCALAR);
316 I8(__fort_set_single)(ac, as, array_dim, ai, __SCALAR);
317
318 if (loop_dim > 1)
319 I8(eoshift_loop)(rb, ab, sb, bb, shift_dim, rs, as, ss, bs, rc, ac,
320 soff, boff, loop_dim-1);
321 else
322
323 I8(eoshift_scalar)(rb, ab, sb[soff], bb + boff*F90_LEN_G(bs),
324 shift_dim, rs, as, rc, ac, 1);
325
326 /* restore descriptor fields */
327
328 F90_FLAGS_P(ac, aflags);
329 F90_LBASE_P(ac, albase);
330 DIST_PBASE_P(ac, apbase);
331 DIST_REPLICATED_P(ac, arepli);
332 DIST_SCOFF_P(ac, ascoff);
333 DIST_CACHED_P(ac, 0);
334
335 F90_FLAGS_P(rc, rflags);
336 F90_LBASE_P(rc, rlbase);
337 DIST_PBASE_P(rc, rpbase);
338 DIST_REPLICATED_P(rc, rrepli);
339 DIST_SCOFF_P(rc, rscoff);
340 DIST_CACHED_P(rc, 0);
341 }
342 }
343
344 /* eoshift (..., shift=scalar), boundary absent */
345
ENTFTN(EOSHIFTSZ,eoshiftsz)346 void ENTFTN(EOSHIFTSZ, eoshiftsz)(char *rb, /* result base */
347 char *ab, /* array base */
348 __INT_T *sb, /* shift base */
349 __INT_T *db, /* dimension */
350 F90_Desc *rs, /* result descriptor */
351 F90_Desc *as, /* array descriptor */
352 F90_Desc *ss, /* shift descriptor */
353 F90_Desc *ds) /* dim descriptor */
354 {
355 char *bb;
356 DECL_HDR_VARS(ac);
357 DECL_HDR_VARS(rc);
358 DECL_DIM_PTRS(asd);
359 DECL_DIM_PTRS(rsd);
360 __INT_T dim, i, shift;
361
362 shift = *sb;
363 dim = *db;
364 bb = (F90_KIND_G(rs) == __STR) ? " " : (char *)GET_DIST_ZED;
365
366 #if defined(DEBUG)
367 if (__fort_test & DEBUG_EOSH) {
368 printf("%d r", GET_DIST_LCPU);
369 I8(__fort_show_section)(rs);
370 printf("@%x = EOSHIFT(a", rb);
371 I8(__fort_show_section)(as);
372 printf("@%x, shift=%d, dim=%d)\n", ab, shift, dim);
373 }
374 #endif
375
376 /* initialize section descriptors */
377
378 __DIST_INIT_SECTION(ac, F90_RANK_G(as), as);
379 __DIST_INIT_SECTION(rc, F90_RANK_G(rs), rs);
380
381 for (i = 1; i <= F90_RANK_G(as); ++i) {
382 if (i == dim)
383 continue;
384 SET_DIM_PTRS(asd, as, i - 1);
385 I8(__fort_set_section)(ac, i, as, i, F90_DPTR_LBOUND_G(asd),
386 DPTR_UBOUND_G(asd), 1);
387 SET_DIM_PTRS(rsd, rs, i - 1);
388 I8(__fort_set_section)(rc, i, rs, i, F90_DPTR_LBOUND_G(rsd),
389 DPTR_UBOUND_G(rsd), 1);
390 }
391
392 I8(eoshift_scalar)(rb, ab, shift, bb, dim, rs, as, rc, ac, dim);
393 }
394
ENTFTN(EOSHIFTSZCA,eoshiftszca)395 void ENTFTN(EOSHIFTSZCA, eoshiftszca)(DCHAR(rb), /* result char base */
396 DCHAR(ab), /* array char base */
397 __INT_T *sb, /* shift base */
398 __INT_T *db, /* dimension */
399 F90_Desc *rs, /* result descriptor */
400 F90_Desc *as, /* array descriptor */
401 F90_Desc *ss, /* shift descriptor */
402 F90_Desc *ds /* dim descriptor */
403 DCLEN64(rb) /* result char len */
404 DCLEN64(ab)) /* array char len */
405 {
406 ENTFTN(EOSHIFTSZ, eoshiftsz)(CADR(rb), CADR(ab), sb, db, rs, as, ss, ds);
407 }
408
409 /* 32 bit CLEN version */
ENTFTN(EOSHIFTSZC,eoshiftszc)410 void ENTFTN(EOSHIFTSZC, eoshiftszc)(DCHAR(rb), /* result char base */
411 DCHAR(ab), /* array char base */
412 __INT_T *sb, /* shift base */
413 __INT_T *db, /* dimension */
414 F90_Desc *rs, /* result descriptor */
415 F90_Desc *as, /* array descriptor */
416 F90_Desc *ss, /* shift descriptor */
417 F90_Desc *ds /* dim descriptor */
418 DCLEN(rb) /* result char len */
419 DCLEN(ab)) /* array char len */
420 {
421 ENTFTN(EOSHIFTSZCA, eoshiftszca)(CADR(rb), CADR(ab), sb, db, rs, as, ss, ds,
422 (__CLEN_T)CLEN(rb), (__CLEN_T)CLEN(ab));
423 }
424
425 /* eoshift (..., shift=scalar, boundary=scalar) */
426
ENTFTN(EOSHIFTSS,eoshiftss)427 void ENTFTN(EOSHIFTSS, eoshiftss)(char *rb, /* result base */
428 char *ab, /* array base */
429 __INT_T *sb, /* shift base */
430 __INT_T *db, /* dimension */
431 char *bb, /* boundary base */
432 F90_Desc *rs, /* result descriptor */
433 F90_Desc *as, /* array descriptor */
434 F90_Desc *ss, /* shift descriptor */
435 F90_Desc *ds, /* dim descriptor */
436 F90_Desc *bs) /* boundary descriptor */
437 {
438 DECL_HDR_VARS(ac);
439 DECL_HDR_VARS(rc);
440 DECL_DIM_PTRS(asd);
441 DECL_DIM_PTRS(rsd);
442 __INT_T dim, i, shift;
443
444 shift = *sb;
445 dim = *db;
446
447 #if defined(DEBUG)
448 if (__fort_test & DEBUG_EOSH) {
449 printf("%d r", GET_DIST_LCPU);
450 I8(__fort_show_section)(rs);
451 printf("@%x = EOSHIFT(a", rb);
452 I8(__fort_show_section)(as);
453 printf("@%x, shift=%d, boundary=", ab, shift);
454 __fort_print_scalar(bb, (dtype)F90_TAG_G(bs));
455 printf(", dim=%d)\n", dim);
456 }
457 #endif
458
459 /* initialize section descriptors */
460
461 __DIST_INIT_SECTION(ac, F90_RANK_G(as), as);
462 __DIST_INIT_SECTION(rc, F90_RANK_G(rs), rs);
463
464 for (i = 1; i <= F90_RANK_G(as); ++i) {
465 if (i == dim)
466 continue;
467 SET_DIM_PTRS(asd, as, i - 1);
468 I8(__fort_set_section)(ac, i, as, i, F90_DPTR_LBOUND_G(asd),
469 DPTR_UBOUND_G(asd), 1);
470 SET_DIM_PTRS(rsd, rs, i - 1);
471 I8(__fort_set_section)(rc, i, rs, i, F90_DPTR_LBOUND_G(rsd),
472 DPTR_UBOUND_G(rsd), 1);
473 }
474
475 I8(eoshift_scalar)(rb, ab, shift, bb, dim, rs, as, rc, ac, dim);
476 }
477
ENTFTN(EOSHIFTSSCA,eoshiftssca)478 void ENTFTN(EOSHIFTSSCA, eoshiftssca)(DCHAR(rb), /* result char base */
479 DCHAR(ab), /* array char base */
480 __INT_T *sb, /* shift base */
481 __INT_T *db, /* dimension */
482 DCHAR(bb), /* boundary char base */
483 F90_Desc *rs, /* result descriptor */
484 F90_Desc *as, /* array descriptor */
485 F90_Desc *ss, /* shift descriptor */
486 F90_Desc *ds, /* dim descriptor */
487 F90_Desc *bs /* boundary descriptor */
488 DCLEN64(rb) /* result char len */
489 DCLEN64(ab) /* array char len */
490 DCLEN64(bb)) /* boundary char len */
491 {
492 ENTFTN(EOSHIFTSS,eoshiftss)(CADR(rb), CADR(ab), sb, db, CADR(bb),
493 rs, as, ss, ds, bs);
494 }
495
496 /* 32 bit CLEN version */
ENTFTN(EOSHIFTSSC,eoshiftssc)497 void ENTFTN(EOSHIFTSSC, eoshiftssc)(DCHAR(rb), /* result char base */
498 DCHAR(ab), /* array char base */
499 __INT_T *sb, /* shift base */
500 __INT_T *db, /* dimension */
501 DCHAR(bb), /* boundary char base */
502 F90_Desc *rs, /* result descriptor */
503 F90_Desc *as, /* array descriptor */
504 F90_Desc *ss, /* shift descriptor */
505 F90_Desc *ds, /* dim descriptor */
506 F90_Desc *bs /* boundary descriptor */
507 DCLEN(rb) /* result char len */
508 DCLEN(ab) /* array char len */
509 DCLEN(bb)) /* boundary char len */
510 {
511 ENTFTN(EOSHIFTSSCA, eoshiftssca)(CADR(rb), CADR(ab), sb, db, CADR(bb), rs, as,
512 ss, ds, bs, (__CLEN_T)CLEN(rb), (__CLEN_T)CLEN(ab),
513 (__CLEN_T)CLEN(bb));
514 }
515
516 /* eoshift (..., shift=scalar, boundary=array) */
517
ENTFTN(EOSHIFTSA,eoshiftsa)518 void ENTFTN(EOSHIFTSA, eoshiftsa)(char *rb, /* result base */
519 char *ab, /* array base */
520 __INT_T *sb, /* shift base */
521 __INT_T *db, /* dimension */
522 char *bb, /* boundary base */
523 F90_Desc *rs, /* result descriptor */
524 F90_Desc *as, /* array descriptor */
525 F90_Desc *ss, /* shift descriptor */
526 F90_Desc *ds, /* dim descriptor */
527 F90_Desc *bs) /* boundary descriptor */
528 {
529 DECL_HDR_VARS(ac);
530 DECL_HDR_VARS(rc);
531 __INT_T dim, i, shift;
532
533 shift = *sb;
534 dim = *db;
535
536 #if defined(DEBUG)
537 if (__fort_test & DEBUG_EOSH) {
538 printf("%d r", GET_DIST_LCPU);
539 I8(__fort_show_section)(rs);
540 printf("@%x = EOSHIFT(a", rb);
541 I8(__fort_show_section)(as);
542 printf("@%x, shift=%d, boundary=b", ab, shift);
543 I8(__fort_show_section)(bs);
544 printf("@%x, dim=%d)\n", bb, dim);
545 }
546 #endif
547
548 /* initialize rank 1 section descriptors */
549
550 __DIST_INIT_SECTION(rc, 1, rs);
551 __DIST_INIT_SECTION(ac, 1, as);
552
553 I8(eoshift_loop)(rb, ab, sb, bb, dim, rs, as, ss, bs,
554 rc, ac, 0, F90_LBASE_G(bs) - 1, F90_RANK_G(bs));
555 }
556
ENTFTN(EOSHIFTSACA,eoshiftsaca)557 void ENTFTN(EOSHIFTSACA, eoshiftsaca)(DCHAR(rb), /* result char base */
558 DCHAR(ab), /* array char base */
559 __INT_T *sb, /* shift char base */
560 __INT_T *db, /* dimension */
561 DCHAR(bb), /* boundary base */
562 F90_Desc *rs, /* result descriptor */
563 F90_Desc *as, /* array descriptor */
564 F90_Desc *ss, /* shift descriptor */
565 F90_Desc *ds, /* dim descriptor */
566 F90_Desc *bs /* boundary descriptor */
567 DCLEN64(rb) /* result char len */
568 DCLEN64(ab) /* array char len */
569 DCLEN64(bb)) /* boundary char len */
570 {
571 ENTFTN(EOSHIFTSA,eoshiftsa)(CADR(rb), CADR(ab), sb, db, CADR(bb),
572 rs, as, ss, ds, bs);
573 }
574
575 /* 32 bit CLEN version */
ENTFTN(EOSHIFTSAC,eoshiftsac)576 void ENTFTN(EOSHIFTSAC, eoshiftsac)(DCHAR(rb), /* result char base */
577 DCHAR(ab), /* array char base */
578 __INT_T *sb, /* shift char base */
579 __INT_T *db, /* dimension */
580 DCHAR(bb), /* boundary base */
581 F90_Desc *rs, /* result descriptor */
582 F90_Desc *as, /* array descriptor */
583 F90_Desc *ss, /* shift descriptor */
584 F90_Desc *ds, /* dim descriptor */
585 F90_Desc *bs /* boundary descriptor */
586 DCLEN(rb) /* result char len */
587 DCLEN(ab) /* array char len */
588 DCLEN(bb)) /* boundary char len */
589 {
590 ENTFTN(EOSHIFTSACA, eoshiftsaca)(CADR(rb), CADR(ab), sb, db, CADR(bb), rs, as,
591 ss, ds, bs, (__CLEN_T)CLEN(rb), (__CLEN_T)CLEN(ab),
592 (__CLEN_T)CLEN(bb));
593 }
594
595 /* eoshift (..., shift=array), boundary absent */
596
ENTFTN(EOSHIFTZ,eoshiftz)597 void ENTFTN(EOSHIFTZ, eoshiftz)(char *rb, /* result base */
598 char *ab, /* array base */
599 __INT_T *sb, /* shift base */
600 __INT_T *db, /* dimension to shift */
601 F90_Desc *rs, /* result descriptor */
602 F90_Desc *as, /* array descriptor */
603 F90_Desc *ss, /* shift descriptor */
604 F90_Desc *ds) /* dim descriptor */
605 {
606 DECL_HDR_PTRS(bs);
607 DECL_HDR_VARS(ac);
608 DECL_HDR_VARS(rc);
609 char *bb;
610 __INT_T dim;
611
612 dim = *db;
613 bb = (F90_KIND_G(rs) == __STR) ? " " : (char *)GET_DIST_ZED;
614 bs = (F90_Desc *)&F90_KIND_G(rs);
615
616 #if defined(DEBUG)
617 if (__fort_test & DEBUG_EOSH) {
618 printf("%d r", GET_DIST_LCPU);
619 I8(__fort_show_section)(rs);
620 printf("@%x = EOSHIFT(a", rb);
621 I8(__fort_show_section)(as);
622 printf("@%x, shift=s", ab);
623 I8(__fort_show_section)(ss);
624 printf("@%x, dim=%d)\n", sb, dim);
625 }
626 #endif
627
628 /* initialize rank 1 section descriptors */
629
630 __DIST_INIT_SECTION(rc, 1, rs);
631 __DIST_INIT_SECTION(ac, 1, as);
632
633 /* loop over all shift array elements */
634
635 I8(eoshift_loop)(rb, ab, sb, bb, dim, rs, as, ss, bs,
636 rc, ac, F90_LBASE_G(ss) - 1, 0, F90_RANK_G(ss));
637 }
638
ENTFTN(EOSHIFTZCA,eoshiftzca)639 void ENTFTN(EOSHIFTZCA, eoshiftzca)(DCHAR(rb), /* result char base */
640 DCHAR(ab), /* array char base */
641 __INT_T *sb, /* shift base */
642 __INT_T *db, /* dimension to shift */
643 F90_Desc *rs, /* result descriptor */
644 F90_Desc *as, /* array descriptor */
645 F90_Desc *ss, /* shift descriptor */
646 F90_Desc *ds /* dim descriptor */
647 DCLEN64(rb) /* result char len */
648 DCLEN64(ab)) /* array char len */
649 {
650 ENTFTN(EOSHIFTZ, eoshiftz)(CADR(rb), CADR(ab), sb, db, rs, as, ss, ds);
651 }
652
653 /* 32 bit CLEN version */
ENTFTN(EOSHIFTZC,eoshiftzc)654 void ENTFTN(EOSHIFTZC, eoshiftzc)(DCHAR(rb), /* result char base */
655 DCHAR(ab), /* array char base */
656 __INT_T *sb, /* shift base */
657 __INT_T *db, /* dimension to shift */
658 F90_Desc *rs, /* result descriptor */
659 F90_Desc *as, /* array descriptor */
660 F90_Desc *ss, /* shift descriptor */
661 F90_Desc *ds /* dim descriptor */
662 DCLEN(rb) /* result char len */
663 DCLEN(ab)) /* array char len */
664 {
665 ENTFTN(EOSHIFTZCA, eoshiftzca)(CADR(rb), CADR(ab), sb, db, rs, as, ss, ds,
666 (__CLEN_T)CLEN(rb), (__CLEN_T)CLEN(ab));
667 }
668
669 /* eoshift (..., shift=array, boundary=scalar) */
670
ENTFTN(EOSHIFTS,eoshifts)671 void ENTFTN(EOSHIFTS, eoshifts)(char *rb, /* result base */
672 char *ab, /* array base */
673 __INT_T *sb, /* shift base */
674 __INT_T *db, /* dimension to shift */
675 char *bb, /* boundary base */
676 F90_Desc *rs, /* result descriptor */
677 F90_Desc *as, /* array descriptor */
678 F90_Desc *ss, /* shift descriptor */
679 F90_Desc *ds, /* dim descriptor */
680 F90_Desc *bs) /* boundary descriptor */
681 {
682 DECL_HDR_VARS(ac);
683 DECL_HDR_VARS(rc);
684 __INT_T dim;
685
686 dim = *db;
687
688 #if defined(DEBUG)
689 if (__fort_test & DEBUG_EOSH) {
690 printf("%d r", GET_DIST_LCPU);
691 I8(__fort_show_section)(rs);
692 printf("@%x = EOSHIFT(a", rb);
693 I8(__fort_show_section)(as);
694 printf("@%x, shift=s", ab);
695 I8(__fort_show_section)(ss);
696 printf("@%x, boundary=", sb);
697 __fort_print_scalar(bb, (dtype)F90_TAG_G(bs));
698 printf(", dim=%d)\n", dim);
699 }
700 #endif
701
702 /* initialize rank 1 section descriptors */
703
704 __DIST_INIT_SECTION(rc, 1, rs);
705 __DIST_INIT_SECTION(ac, 1, as);
706
707 /* loop over all shift array elements */
708
709 I8(eoshift_loop)(rb, ab, sb, bb, dim, rs, as, ss, bs,
710 rc, ac, F90_LBASE_G(ss) - 1, 0, F90_RANK_G(ss));
711 }
712
ENTFTN(EOSHIFTSCA,eoshiftsca)713 void ENTFTN(EOSHIFTSCA, eoshiftsca)(DCHAR(rb), /* result char base */
714 DCHAR(ab), /* array char base */
715 __INT_T *sb, /* shift char base */
716 __INT_T *db, /* dimension to shift */
717 DCHAR(bb), /* boundary base */
718 F90_Desc *rs, /* result descriptor */
719 F90_Desc *as, /* array descriptor */
720 F90_Desc *ss, /* shift descriptor */
721 F90_Desc *ds, /* dim descriptor */
722 F90_Desc *bs /* boundary descriptor */
723 DCLEN64(rb) /* result char len */
724 DCLEN64(ab) /* array char len */
725 DCLEN64(bb)) /* boundary char len */
726 {
727 ENTFTN(EOSHIFTS,eoshifts)(CADR(rb), CADR(ab), sb, db, CADR(bb),
728 rs, as, ss, ds, bs);
729 }
730
731 /* 32 bit CLEN version */
ENTFTN(EOSHIFTSC,eoshiftsc)732 void ENTFTN(EOSHIFTSC, eoshiftsc)(DCHAR(rb), /* result char base */
733 DCHAR(ab), /* array char base */
734 __INT_T *sb, /* shift char base */
735 __INT_T *db, /* dimension to shift */
736 DCHAR(bb), /* boundary base */
737 F90_Desc *rs, /* result descriptor */
738 F90_Desc *as, /* array descriptor */
739 F90_Desc *ss, /* shift descriptor */
740 F90_Desc *ds, /* dim descriptor */
741 F90_Desc *bs /* boundary descriptor */
742 DCLEN(rb) /* result char len */
743 DCLEN(ab) /* array char len */
744 DCLEN(bb)) /* boundary char len */
745 {
746 ENTFTN(EOSHIFTSCA, eoshiftsca)(CADR(rb), CADR(ab), sb, db, CADR(bb), rs, as,
747 ss, ds, bs, (__CLEN_T)CLEN(rb), (__CLEN_T)CLEN(ab),
748 (__CLEN_T)CLEN(bb));
749 }
750
751 /* eoshift (..., shift=array, boundary=array) */
752
ENTFTN(EOSHIFT,eoshift)753 void ENTFTN(EOSHIFT, eoshift)(char *rb, /* result base */
754 char *ab, /* array base */
755 __INT_T *sb, /* shift base */
756 __INT_T *db, /* dimension to shift */
757 char *bb, /* boundary base */
758 F90_Desc *rs, /* result descriptor */
759 F90_Desc *as, /* array descriptor */
760 F90_Desc *ss, /* shift descriptor */
761 F90_Desc *ds, /* dim descriptor */
762 F90_Desc *bs) /* boundary descriptor */
763 {
764 DECL_HDR_VARS(ac);
765 DECL_HDR_VARS(rc);
766 __INT_T dim;
767
768 dim = *db;
769
770 #if defined(DEBUG)
771 if (__fort_test & DEBUG_EOSH) {
772 printf("%d r", GET_DIST_LCPU);
773 I8(__fort_show_section)(rs);
774 printf("@%x = EOSHIFT(a", rb);
775 I8(__fort_show_section)(as);
776 printf("@%x, shift=s", ab);
777 I8(__fort_show_section)(ss);
778 printf("@%x, boundary=b", sb);
779 I8(__fort_show_section)(bs);
780 printf("@%x, dim=%d)\n", bb, dim);
781 }
782 #endif
783
784 /* initialize rank 1 section descriptors */
785
786 __DIST_INIT_SECTION(rc, 1, rs);
787 __DIST_INIT_SECTION(ac, 1, as);
788
789 /* loop over all shift array elements */
790
791 I8(eoshift_loop)(rb, ab, sb, bb, dim, rs, as, ss, bs,
792 rc, ac, F90_LBASE_G(ss) - 1, F90_LBASE_G(bs) - 1,
793 F90_RANK_G(ss));
794 }
795
ENTFTN(EOSHIFTCA,eoshiftca)796 void ENTFTN(EOSHIFTCA, eoshiftca)(DCHAR(rb), /* result base */
797 DCHAR(ab), /* array base */
798 __INT_T *sb, /* shift base */
799 __INT_T *db, /* dimension to shift */
800 DCHAR(bb), /* boundary base */
801 F90_Desc *rs, /* result descriptor */
802 F90_Desc *as, /* array descriptor */
803 F90_Desc *ss, /* shift descriptor */
804 F90_Desc *ds, /* dim descriptor */
805 F90_Desc *bs /* boundary descriptor */
806 DCLEN64(rb) /* result char len */
807 DCLEN64(ab) /* array char len */
808 DCLEN64(bb)) /* boundary char len */
809 {
810 ENTFTN(EOSHIFT,eoshift)(CADR(rb), CADR(ab), sb, db, CADR(bb),
811 rs, as, ss, ds, bs);
812 }
813
814 /* 32 bit CLEN version */
ENTFTN(EOSHIFTC,eoshiftc)815 void ENTFTN(EOSHIFTC, eoshiftc)(DCHAR(rb), /* result base */
816 DCHAR(ab), /* array base */
817 __INT_T *sb, /* shift base */
818 __INT_T *db, /* dimension to shift */
819 DCHAR(bb), /* boundary base */
820 F90_Desc *rs, /* result descriptor */
821 F90_Desc *as, /* array descriptor */
822 F90_Desc *ss, /* shift descriptor */
823 F90_Desc *ds, /* dim descriptor */
824 F90_Desc *bs /* boundary descriptor */
825 DCLEN(rb) /* result char len */
826 DCLEN(ab) /* array char len */
827 DCLEN(bb)) /* boundary char len */
828 {
829 ENTFTN(EOSHIFTCA, eoshiftca)(CADR(rb), CADR(ab), sb, db, CADR(bb), rs, as, ss,
830 ds, bs, (__CLEN_T)CLEN(rb), (__CLEN_T)CLEN(ab),
831 (__CLEN_T)CLEN(bb));
832 }
833