1 /*
2 * Copyright (c) 2017, 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 /** \file
21 * \brief Dynamic, realign, redistribute arrays
22 */
23
24 #include "stdioInterf.h"
25 #include "fioMacros.h"
26
27 #include "fort_vars.h"
28
29 /* reallocate and copy. ad = new descriptor, dd = old descriptor, pd
30 = descriptor associated with pointer and offset variables, i.e. the
31 original descriptor location. */
32 static void
I8(recopy)33 I8(recopy)(F90_Desc *ad, F90_Desc *dd, F90_Desc *pd)
34 {
35 char *ab, *af, *db, *df, *base, **ptr;
36 __POINT_T *off;
37 chdr *ch;
38
39 if (F90_FLAGS_G(ad) & __TEMPLATE)
40 return;
41
42 ptr = ((char **)pd) - 2; /* array pointer variable */
43 off = (__POINT_T *)(ptr + 1); /* array offset variable */
44
45 db = *ptr; /* array address */
46
47 if (!ISPRESENT(db))
48 return;
49
50 /* allocate the new array */
51
52 base = db - (*off - 1) * F90_LEN_G(ad);
53 ab = I8(__fort_allocate)(F90_LSIZE_G(ad), F90_KIND_G(ad), F90_LEN_G(ad), base,
54 ptr, off);
55
56 /* copy the old into the new */
57
58 af = ab + DIST_SCOFF_G(ad) * F90_LEN_G(ad);
59 df = db + DIST_SCOFF_G(dd) * F90_LEN_G(dd);
60 ch = I8(__fort_copy)(af, df, ad, dd, NULL);
61 __fort_doit(ch);
62 __fort_frechn(ch);
63
64 /* free the old array */
65
66 if (~F90_FLAGS_G(dd) & __NOT_COPIED)
67 I8(__fort_deallocate)(db);
68
69 F90_FLAGS_P(ad, F90_FLAGS_G(ad) & ~__NOT_COPIED);
70 #if defined(DEBUG)
71 if (__fort_test & DEBUG_RDST) {
72 printf("%d recopy ab=%x base=%x offset=%x\n", GET_DIST_LCPU, ab, base,
73 *off);
74 }
75 #endif
76 }
77
78 /* \brief realign the alignee with the align-target template 'td'
79 *
80 *<pre>
81 * varargs are:
82 * [ __INT_T *collapse,
83 * { __INT_T *taxis, __INT_T *tstride, __INT_T *toffset, }*
84 * __INT_T *single, { __INT_T *coordinate, }* ]
85 *</pre>
86 */
87 void
ENTFTN(REALIGN,realign)88 ENTFTN(REALIGN, realign)(F90_Desc *ad, __INT_T *p_rank, __INT_T *p_flags,
89 F90_Desc *td, __INT_T *p_conform, ...)
90 {
91 va_list va;
92 DECL_HDR_VARS(dd);
93 DECL_HDR_PTRS(ud);
94 DECL_HDR_PTRS(prev);
95 DECL_HDR_PTRS(next);
96 DECL_DIM_PTRS(add);
97 DECL_DIM_PTRS(ddd);
98 DECL_DIM_PTRS(tdd);
99 proc *ap, *tp;
100 __INT_T flags, conform, collapse, m, single = 0;
101 __INT_T taxis[MAXDIMS], tstride[MAXDIMS], toffset[MAXDIMS];
102 __INT_T coordinate[MAXDIMS];
103 __INT_T ak, i, realign, rank, tk, tm, px, tx;
104
105 rank = *p_rank;
106 flags = *p_flags;
107
108 #if defined(DEBUG)
109 if (__fort_test & DEBUG_RDST) {
110 printf("%d REALIGN alignee=%x new-align-target=%x\n", GET_DIST_LCPU, ad,
111 td);
112 __fort_show_flags(flags);
113 printf("\n");
114 }
115 if (ad == NULL || F90_TAG_G(ad) != __DESC)
116 __fort_abort("REALIGN: invalid alignee descriptor");
117 if (td == NULL || F90_TAG_G(td) != __DESC)
118 __fort_abort("REALIGN: invalid new-align-target descriptor");
119 if (~F90_FLAGS_G(ad) & __DYNAMIC)
120 __fort_abort("REALIGN: alignee is not DYNAMIC");
121 if (F90_RANK_G(ad) != rank)
122 __fort_abort("REALIGN: alignee rank differs");
123 if (flags &
124 (__DIST_TARGET_MASK << __DIST_TARGET_SHIFT |
125 __DIST_FORMAT_MASK << __DIST_FORMAT_SHIFT | __INHERIT | __SEQUENCE))
126 __fort_abort("REALIGN: distribution, inherit, or sequence disallowed");
127 #endif
128
129 va_start(va, p_conform);
130
131 if (flags & __IDENTITY_MAP) {
132 collapse = 0;
133 for (i = 1; i <= rank; ++i) {
134 taxis[i - 1] = i;
135 tstride[i - 1] = 1;
136 toffset[i - 1] = 0;
137 }
138 } else {
139 collapse = *va_arg(va, __INT_T *);
140
141 for (i = 0; i < rank; ++i) {
142 if (collapse >> i & 1) {
143 taxis[i] = 0;
144 tstride[i] = 1;
145 toffset[i] = 0;
146 } else {
147 taxis[i] = *va_arg(va, __INT_T *);
148 tstride[i] = *va_arg(va, __INT_T *);
149 toffset[i] = *va_arg(va, __INT_T *);
150 }
151 }
152 single = *va_arg(va, __INT_T *);
153 if (single >> F90_RANK_G(td))
154 __fort_abort("REALIGN: invalid single alignment axis");
155 for (i = 0; i < F90_RANK_G(td); ++i) {
156 if (single >> i & 1)
157 coordinate[i] = *va_arg(va, __INT_T *);
158 else
159 coordinate[i] = 0;
160 }
161 }
162 va_end(va);
163
164 ap = DIST_DIST_TARGET_G(ad);
165 tp = DIST_DIST_TARGET_G(td);
166
167 realign = (ap->base != tp->base || ap->size != tp->size);
168
169 for (i = 0; !realign && i < rank; ++i) {
170 SET_DIM_PTRS(add, ad, i);
171
172 /* realignment required if different processor axes are
173 targeted or if the processor shapes or strides differ */
174
175 tx = taxis[i];
176 if (tx > 0) {
177 SET_DIM_PTRS(tdd, td, tx - 1);
178 px = DIST_DPTR_PAXIS_G(tdd);
179 } else
180 px = 0;
181
182 realign = (px != DIST_DPTR_PAXIS_G(add));
183 if (realign)
184 break;
185
186 if (px == 0)
187 continue; /* collapsed dimension */
188
189 realign = (DIST_DPTR_PSHAPE_G(add) != DIST_DPTR_PSHAPE_G(tdd) ||
190 DIST_DPTR_PSTRIDE_G(add) != DIST_DPTR_PSTRIDE_G(tdd));
191 if (realign)
192 break;
193
194 /* realignment required if the template mappings aren't
195 equivalent... */
196
197 /* offset in ultimately-aligned template of actual array */
198
199 ak = DIST_DPTR_TSTRIDE_G(add) * F90_DPTR_LBOUND_G(add) +
200 DIST_DPTR_TOFFSET_G(add) - DIST_DPTR_TLB_G(add);
201
202 /* mapping onto ultimate align-target */
203
204 tm = DIST_DPTR_TSTRIDE_G(tdd) * tstride[i];
205 tk = DIST_DPTR_TSTRIDE_G(tdd) * toffset[i] + DIST_DPTR_TOFFSET_G(tdd);
206
207 /* offset in ultimately-aligned template of align-target */
208
209 tk = tm * F90_DPTR_LBOUND_G(tdd) + tk - DIST_DPTR_TLB_G(tdd);
210
211 #if defined(DEBUG)
212 if (__fort_test & DEBUG_RDST) {
213 printf("%d target tm=%d tk=%d tb=%d tmab=%d tkab=%d\n", GET_DIST_LCPU,
214 tm, tk, DIST_DPTR_BLOCK_G(tdd), tm * DIST_DPTR_BLOCK_G(add),
215 tk * DIST_DPTR_BLOCK_G(add));
216 printf("%d actual am=%d ak=%d ab=%d amtb=%d aktb=%d\n", GET_DIST_LCPU,
217 DIST_DPTR_TSTRIDE_G(add), ak, DIST_DPTR_BLOCK_G(add),
218 DIST_DPTR_TSTRIDE_G(add) * DIST_DPTR_BLOCK_G(tdd),
219 ak * DIST_DPTR_BLOCK_G(tdd));
220 }
221 #endif
222 realign = (DIST_DPTR_BLOCK_G(tdd) * DIST_DPTR_TSTRIDE_G(add) !=
223 DIST_DPTR_BLOCK_G(add) * tm ||
224 DIST_DPTR_BLOCK_G(tdd) * ak != DIST_DPTR_BLOCK_G(add) * tk);
225 }
226
227 ud = DIST_ALIGN_TARGET_G(ad);
228 #if defined(DEBUG)
229 if (ud == NULL || F90_TAG_G(ud) != __DESC)
230 __fort_abort("REALIGN: invalid old align-target descriptor");
231 if (DIST_ALIGN_TARGET_G(ud) != ud)
232 __fort_abort("REALIGN: old align-target is not ultimate align-target");
233 #endif
234
235 if (F90_FLAGS_G(ud) & __DYNAMIC) {
236 if (ud == ad) {
237
238 /* array is distributee */
239
240 if (DIST_NEXT_ALIGNEE_G(ad) != NULL)
241 __fort_abort("REALIGN: array is dynamic align-target");
242 } else {
243
244 /* unlink from old ultimate align-target's alignees list */
245
246 prev = ud;
247 next = DIST_NEXT_ALIGNEE_G(ud);
248 while (next != NULL && next != ad) {
249 prev = next;
250 next = DIST_NEXT_ALIGNEE_G(prev);
251 }
252 if (next != ad)
253 __fort_abort("REALIGN: alignee not in old align-target's list");
254
255 DIST_NEXT_ALIGNEE_P(prev, DIST_NEXT_ALIGNEE_G(ad));
256 #if defined(DEBUG)
257 if (__fort_test & DEBUG_RDST) {
258 printf("%d unlinked ud=%x prev=%x next=%lx\n", GET_DIST_LCPU, ud, prev,
259 DIST_NEXT_ALIGNEE_G(prev));
260 }
261 #endif
262 }
263 }
264
265 if (realign) {
266
267 /* make a copy of the old descriptor */
268
269 I8(__fort_copy_descriptor)(dd, ad);
270
271 /* update the descriptor in place. init_descriptor links the
272 descriptor to the new ultimate align-target. */
273
274 ud = DIST_ALIGN_TARGET_G(td);
275
276 __DIST_INIT_DESCRIPTOR(ad, F90_RANK_G(ad), F90_KIND_G(ad), F90_LEN_G(ad),
277 flags, ud);
278 for (i = 1; i <= rank; ++i) {
279 tx = taxis[i - 1];
280 if (tx > 0) {
281 SET_DIM_PTRS(tdd, td, tx - 1);
282 tx = DIST_DPTR_TAXIS_G(tdd);
283 }
284 if (tx > 0) {
285 tm = DIST_DPTR_TSTRIDE_G(tdd) * tstride[i - 1];
286 tk = DIST_DPTR_TSTRIDE_G(tdd) * toffset[i - 1] + DIST_DPTR_TOFFSET_G(tdd);
287 } else {
288 tm = 1;
289 tk = 0;
290 }
291 SET_DIM_PTRS(ddd, dd, i - 1);
292
293 /*
294 * added last arg which passes the gen_block field in...
295 */
296
297 I8(__fort_set_alignment)(ad, i, F90_DPTR_LBOUND_G(ddd),
298 DPTR_UBOUND_G(ddd), tx, tm, tk,
299 (tx>0)?(&DIST_DPTR_GEN_BLOCK_G(tdd)):
300 (&DIST_DPTR_GEN_BLOCK_G(ddd)));
301 }
302 /* NEC 127 / tpr 2597 */
303
304 m = single;
305 for (i = 1; m > 0; ++i, m >>= 1) {
306 if (m & 1)
307 I8(__fort_set_single)(ad, td, i, coordinate[i - 1], __SINGLE);
308 }
309 m = DIST_SINGLE_G(td);
310 for (i = 1; m > 0; ++i, m >>= 1) {
311 if (m & 1)
312 I8(__fort_set_single)(ad, DIST_ALIGN_TARGET_G(td), i,
313 DIST_INFO_G(td, i-1), __SINGLE);
314 }
315
316 for (i = 1; i <= rank; ++i) {
317 SET_DIM_PTRS(ddd, dd, i - 1);
318 if (~F90_FLAGS_G(dd) & __TEMPLATE)
319 __DIST_SET_ALLOCATION(ad, i, DIST_DPTR_NO_G(ddd), DIST_DPTR_PO_G(ddd));
320 }
321
322 I8(__fort_finish_descriptor)(ad);
323
324 #if defined(DEBUG)
325 if (__fort_test & DEBUG_RDST) {
326 printf("%d linked ud=%x next=%lx\n", GET_DIST_LCPU, ud,
327 DIST_NEXT_ALIGNEE_G(ud));
328 }
329 #endif
330
331 /* reallocate and copy the old into the new */
332
333 I8(recopy)(ad, dd, ad);
334 } else {
335
336 /* link to new align-target. descriptor does not need to
337 change and array does not need to be copied. */
338
339 DIST_ALIGN_TARGET_P(ad, DIST_ALIGN_TARGET_G(td));
340 DIST_DIST_TARGET_P(ad, DIST_DIST_TARGET_G(td));
341 DIST_NEXT_ALIGNEE_P(ad, DIST_NEXT_ALIGNEE_G(td));
342 DIST_NEXT_ALIGNEE_P(td, ad);
343 }
344 }
345
346 /** \brief redistribute the distributee and all objects that are currently
347 * ultimately-aligned with it (within the scope of the calling
348 * subprogram). redistribution does not change alignment
349 * relationships.
350 *
351 *<pre>
352 * varargs are:
353 * [ proc *dist_target, ]
354 * __INT_T *isstar,
355 * { [__INT_T paxis,](__INT_T *dstfmt, |
356 * (__INT_T * gen_block_array, __INT_T extent) ) }*
357 *</pre>
358 */
359 void
ENTFTN(REDISTRIBUTE,redistribute)360 ENTFTN(REDISTRIBUTE, redistribute)(F90_Desc *dd, __INT_T *p_rank,
361 __INT_T *p_flags, ...)
362 {
363 va_list va;
364 DECL_HDR_PTRS(ad);
365 DECL_HDR_PTRS(ud);
366 DECL_HDR_PTRS(next);
367 DECL_DIM_PTRS(odd);
368 DECL_DIM_PTRS(udd);
369 proc *tp, *up;
370 DECL_HDR_VARS(od);
371 DECL_HDR_VARS(td);
372 __INT_T nmapped, block[MAXDIMS];
373 __INT_T flags, dist_format_spec, dist_target_spec;
374 __INT_T isstar, paxis[MAXDIMS];
375 __INT_T dfmt, ddfmt, tdfmt, i, rank, redistribute = 0, ux;
376
377 __INT_T *gbCopy[MAXDIMS]; /*hold gen_block dims*/
378 __INT_T gbIdx = 0, j;
379
380 for (i = 0; i < MAXDIMS; ++i)
381 gbCopy[i] = 0;
382
383 rank = *p_rank;
384 flags = *p_flags;
385
386 dist_target_spec =
387 (_io_spec)(flags >> __DIST_TARGET_SHIFT & __DIST_TARGET_MASK);
388 dist_format_spec =
389 (_io_spec)(flags >> __DIST_FORMAT_SHIFT & __DIST_FORMAT_MASK);
390
391 #if defined(DEBUG)
392 if (dd == NULL || F90_TAG_G(dd) != __DESC)
393 __fort_abort("REDISTRIBUTE: invalid distributee descriptor");
394 if (F90_RANK_G(dd) != rank)
395 __fort_abort("REDISTRIBUTE: distributee has incorrect rank");
396 if (flags & (__ALIGN_TARGET_MASK << __ALIGN_TARGET_SHIFT | __SEQUENCE))
397 __fort_abort("REDISTRIBUTE: invalid flags");
398 #endif
399
400 ud = DIST_ALIGN_TARGET_G(dd);
401
402 #if defined(DEBUG)
403 if (ud == NULL || F90_TAG_G(ud) != __DESC)
404 __fort_abort("REDISTRIBUTE: invalid ultimate template descriptor");
405 if (DIST_ALIGN_TARGET_G(ud) != ud)
406 __fort_abort("REDISTRIBUTE: template is not ultimate align-target");
407 if (~F90_FLAGS_G(ud) & __DYNAMIC)
408 __fort_abort("REDISTRIBUTE: ultimate template is not DYNAMIC");
409
410 if (__fort_test & DEBUG_RDST) {
411 printf("%d REDISTRIBUTE distributee=%x ultimate template=%x\n",
412 GET_DIST_LCPU, dd, ud);
413 __fort_show_flags(flags);
414 printf("\n");
415 }
416 #endif
417 if (F90_RANK_G(ud) != rank)
418 __fort_abort("REDISTRIBUTE: ultimate template has incorrect rank");
419
420 /* get distribution target spec */
421
422 va_start(va, p_flags);
423
424 switch (dist_target_spec) {
425
426 case __PRESCRIPTIVE:
427 tp = va_arg(va, proc *);
428 break;
429
430 case __OMITTED:
431 tp = NULL;
432 break;
433
434 case __DESCRIPTIVE:
435 case __TRANSCRIPTIVE:
436 default:
437 __fort_abort("REDISTRIBUTE: bad dist-target flags");
438 }
439
440 /* get distribution format spec */
441
442 nmapped = 0; /* no. of distributed dimensions */
443 ddfmt = 0;
444
445 switch (dist_format_spec) {
446
447 case __PRESCRIPTIVE:
448 isstar = *va_arg(va, __INT_T *);
449 for (i = 0; i < rank; ++i) {
450 if (isstar >> i & 1) {
451 paxis[i] = 0;
452 block[i] = 0;
453 } else if (((isstar & EXTENSION_BLOCK_MASK) >> (7 + 3 * i)) & 0x01) {
454
455 /*
456 * got a gen_block dimension. The arguments for
457 * ENTFTN(redistribute) are slightly different for
458 * gen_block, so we need to handle this as a special
459 * case.
460 */
461
462 if (flags & __DIST_TARGET_AXIS) {
463 paxis[i] = *va_arg(va, __INT_T *);
464 if (paxis[i] != 0)
465 ++nmapped;
466 } else
467 paxis[i] = ++nmapped;
468
469 gbCopy[gbIdx++] = va_arg(va, __INT_T *);
470 block[i] = *va_arg(va, __INT_T *);
471 ddfmt |= DFMT_GEN_BLOCK << DFMT__WIDTH * i;
472 if (DFMT(ud, i + 1) == DFMT_GEN_BLOCK) {
473
474 /* NEC problem 211 / tpr 2488
475 * redistribute if gen_block array changed.
476 */
477
478 int elem;
479 __INT_T *newgb, *oldgb;
480
481 newgb = DIST_DIM_GEN_BLOCK_G(ud, i);
482 oldgb = gbCopy[gbIdx - 1];
483 for (elem = 0; elem < block[i]; ++elem)
484
485 if (*(oldgb + elem) != *(newgb + elem)) {
486 redistribute = 1;
487 break;
488 }
489 }
490 }
491
492 else {
493 int dstfmt;
494
495 if (flags & __DIST_TARGET_AXIS) {
496 paxis[i] = *va_arg(va, __INT_T *);
497 if (paxis[i] != 0)
498 ++nmapped;
499 } else
500 paxis[i] = ++nmapped;
501
502 dstfmt = *va_arg(va, __INT_T *);
503 if (dstfmt >= 0) {
504
505 block[i] = dstfmt;
506 if (dstfmt == 0)
507 ddfmt |= DFMT_BLOCK << DFMT__WIDTH * i;
508 else
509 ddfmt |= DFMT_BLOCK_K << DFMT__WIDTH * i;
510 } else {
511 block[i] = -dstfmt;
512 if (dstfmt == -1)
513 ddfmt |= DFMT_CYCLIC << DFMT__WIDTH * i;
514 else
515 ddfmt |= DFMT_CYCLIC_K << DFMT__WIDTH * i;
516 }
517 }
518 }
519 break;
520
521 case __OMITTED:
522 for (i = 0; i < rank; ++i) {
523 paxis[i] = 0;
524 block[i] = 0;
525 }
526 break;
527
528 case __DESCRIPTIVE:
529 case __TRANSCRIPTIVE:
530 default:
531 __fort_abort("REDISTRIBUTE: bad dist-format flags");
532 }
533 va_end(va);
534
535 if (tp == NULL)
536 tp = __fort_defaultproc(nmapped);
537 else if (tp->tag != __PROC || tp->rank < nmapped)
538 __fort_abort("REDISTRIBUTE: invalid dist-target");
539
540 /* shuffle dist-formats to match align-target axis permutation */
541
542 tdfmt = 0;
543 dfmt = ddfmt;
544 for (i = 0; i < rank; ++i, dfmt >>= DFMT__WIDTH) {
545 if (dfmt & DFMT__MASK) {
546 ux = DIST_DIM_TAXIS_G(dd, i);
547 if (ux > 0)
548 tdfmt |= (dfmt & DFMT__MASK) << DFMT__WIDTH * (ux - 1);
549 else
550 __fort_abort("REDISTRIBUTE: no align-target axis for mapped dim");
551 }
552 }
553
554 /* check conformance of actual distribution vs. dist-target */
555
556 redistribute |= (tdfmt != DIST_DFMT_G(ud));
557 up = DIST_DIST_TARGET_G(ud);
558 if (!redistribute && up != tp) {
559 redistribute =
560 (up->rank != tp->rank || up->base != tp->base || up->size != tp->size);
561 for (i = 0; !redistribute && i < tp->rank; ++i)
562 redistribute = (up->dim[i].shape != tp->dim[i].shape);
563 }
564 for (i = 0; !redistribute && i < rank; ++i) {
565 ux = DIST_DIM_TAXIS_G(dd, i);
566 SET_DIM_PTRS(udd, ud, ux - 1);
567 redistribute = (DIST_DPTR_PAXIS_G(udd) != paxis[i]);
568 if (redistribute)
569 break;
570 switch (DFMT(ud, ux)) {
571 case DFMT_COLLAPSED:
572 case DFMT_BLOCK:
573 case DFMT_CYCLIC:
574 case DFMT_GEN_BLOCK:
575 break;
576 case DFMT_BLOCK_K:
577 case DFMT_CYCLIC_K:
578 redistribute = (DIST_DPTR_BLOCK_G(udd) != block[i]);
579 break;
580 default:
581 __fort_abort("REDISTRIBUTE: unsupported dist-format");
582 }
583 }
584 #if defined(DEBUG)
585 if (__fort_test & DEBUG_RDST) {
586 for (i = 0; i < rank; ++i) {
587 printf("%d dim=%d ddfmt=%d paxis=%d block=%d\n", GET_DIST_LCPU, i + 1,
588 ddfmt >> DFMT__WIDTH * i & DFMT__MASK, paxis[i], block[i]);
589 }
590 printf("%d nmapped=%d redistribute=%d\n", GET_DIST_LCPU, nmapped,
591 redistribute);
592 }
593 #endif
594
595 if (!redistribute)
596 return;
597
598 /* create a duplicate of the new align-target first. After all
599 the alignees have been redistributed, then the original
600 align-target is updated in place and the align-target pointer
601 in each alignee is reset back to the original align-target. */
602
603 __DIST_INIT_DESCRIPTOR(td, rank, F90_KIND_G(ud), F90_LEN_G(ud), flags, tp);
604 j = 0; /*for gen_block*/
605 for (i = 1; i <= rank; ++i) {
606 ux = DIST_DIM_TAXIS_G(dd, i - 1);
607 #if defined(DEBUG)
608 if (ux <= 0)
609 __fort_abort("REDISTRIBUTE: invalid distributee align axis");
610 #endif
611 SET_DIM_PTRS(udd, ud, ux - 1);
612 DIST_DFMT_P(td, tdfmt);
613
614 if ((tdfmt >> DFMT__WIDTH * (i - 1) & DFMT__MASK) == DFMT_GEN_BLOCK) {
615 DIST_DIM_GEN_BLOCK_P(td, i - 1, gbCopy[j++]);
616 } else {
617 DIST_DIM_GEN_BLOCK_P(td, i - 1, 0);
618 }
619
620 __DIST_SET_DISTRIBUTION(td, ux, F90_DPTR_LBOUND_G(udd), DPTR_UBOUND_G(udd),
621 paxis[i - 1], &block[i - 1]);
622
623 if (~F90_FLAGS_G(ud) & __TEMPLATE)
624 __DIST_SET_ALLOCATION(td, ux, DIST_DPTR_NO_G(udd), DIST_DPTR_PO_G(udd));
625 }
626 if (~F90_FLAGS_G(ud) & __TEMPLATE)
627 I8(__fort_finish_descriptor)((td));
628
629 /* reallocate and copy the old into the new */
630
631 I8(recopy)(td, ud, ud);
632
633 /* redistribute each alignee */
634
635 ad = DIST_NEXT_ALIGNEE_G(ud);
636 while (ad != NULL) {
637
638 #if defined(DEBUG)
639 if (ad == ud)
640 __fort_abort("REDISTRIBUTE: distributee in own alignee's list");
641 if (DIST_ALIGN_TARGET_G(ad) != ud)
642 __fort_abort("REDISTRIBUTE: alignee has different align-target");
643 #endif
644
645 /* make a copy of the old alignee descriptor */
646
647 I8(__fort_copy_descriptor)(od, ad);
648
649 /* update alignee descriptor in place */
650
651 __DIST_INIT_DESCRIPTOR(ad, F90_RANK_G(od), F90_KIND_G(od), F90_LEN_G(od),
652 F90_FLAGS_G(od), td);
653 for (i = 1; i <= F90_RANK_G(od); ++i) {
654 int tx;
655
656 SET_DIM_PTRS(odd, od, i - 1);
657
658 /*
659 * pasing gen_block field in thru last arg
660 */
661
662 tx = DIST_DPTR_TAXIS_G(odd);
663
664 I8(__fort_set_alignment)(ad, i, F90_DPTR_LBOUND_G(odd),
665 DPTR_UBOUND_G(odd), tx,
666 DIST_DPTR_TSTRIDE_G(odd),
667 DIST_DPTR_TOFFSET_G(odd),
668 &(DIST_DIM_GEN_BLOCK_G(td,tx-1)));
669 if (~F90_FLAGS_G(od) & __TEMPLATE)
670 __DIST_SET_ALLOCATION(ad, i, DIST_DPTR_NO_G(odd), DIST_DPTR_PO_G(odd));
671 }
672 if (~F90_FLAGS_G(od) & __TEMPLATE)
673 I8(__fort_finish_descriptor)(ad);
674
675 /* reallocate and copy the old into the new */
676
677 I8(recopy)(ad, od, ad);
678
679 /* reset pointers to original align-target and next alignee */
680
681 next = DIST_NEXT_ALIGNEE_G(od);
682 DIST_ALIGN_TARGET_P(ad, ud);
683 DIST_NEXT_ALIGNEE_P(ad, next);
684 ad = next;
685 }
686
687 /* copy the new align-target descriptor into the original location */
688
689 next = DIST_NEXT_ALIGNEE_G(ud);
690 I8(__fort_copy_descriptor)(ud, td);
691 DIST_ALIGN_TARGET_P(ud, ud);
692 DIST_NEXT_ALIGNEE_P(ud, next);
693 }
694