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 /* hpf_library, hpf_local_library, and system inquiry routines */
21
22 /* FIXME: how much (if any) of this is used/needed */
23
24 #include "stdioInterf.h"
25 #include "fioMacros.h"
26
I8(fetch_int)27 static int I8(fetch_int)(void *b, F90_Desc *s)
28 {
29 dtype kind = TYPEKIND(s);
30 switch (kind) {
31 case __INT1:
32 return (int)(*(__INT1_T *)b);
33 case __INT2:
34 return (int)(*(__INT2_T *)b);
35 case __INT4:
36 return (int)(*(__INT4_T *)b);
37 case __INT8:
38 return (int)(*(__INT8_T *)b);
39 default:
40 __fort_abort("fetch_int: invalid argument type");
41 return 0;
42 }
43 }
44
I8(fetch_log)45 static int I8(fetch_log)(void *b, F90_Desc *s)
46 {
47 dtype kind = TYPEKIND(s);
48 switch (kind) {
49 case __LOG1:
50 return (*(__LOG1_T *)b & GET_DIST_MASK_LOG1) != 0;
51 case __LOG2:
52 return (*(__LOG2_T *)b & GET_DIST_MASK_LOG2) != 0;
53 case __LOG4:
54 return (*(__LOG4_T *)b & GET_DIST_MASK_LOG4) != 0;
55 case __LOG8:
56 return (*(__LOG8_T *)b & GET_DIST_MASK_LOG8) != 0;
57 default:
58 __fort_abort("fetch_log: invalid argument type");
59 return 0;
60 }
61 }
62
I8(fetch_vector)63 static void I8(fetch_vector)(void *ab, F90_Desc *as, __INT_T *vector,
64 int veclen)
65 {
66 __INT_T *la;
67 __INT_T i;
68
69 if (F90_RANK_G(as) != 1)
70 __fort_abort("fetch_vector: incorrect argument rank");
71
72 for (i = F90_DIM_LBOUND_G(as, 0); --veclen >= 0; ++i) {
73 la = I8(__fort_local_address)(ab, as, &i);
74 if (la == NULL)
75 __fort_abort("fetch_vector: argument inaccessible");
76 *vector++ = I8(fetch_int)(la, as);
77 }
78 }
79
I8(store_int)80 static void I8(store_int)(void *b, F90_Desc *s, __INT_T val)
81 {
82 dtype kind = TYPEKIND(s);
83 switch (kind) {
84 case __INT1:
85 *(__INT1_T *)b = (__INT1_T)val;
86 break;
87 case __INT2:
88 *(__INT2_T *)b = (__INT2_T)val;
89 break;
90 case __INT4:
91 *(__INT4_T *)b = (__INT4_T)val;
92 break;
93 case __INT8:
94 *(__INT8_T *)b = (__INT8_T)val;
95 break;
96 default:
97 __fort_abort("store_int: invalid argument type (integer expected)");
98 }
99 }
100
I8(store_log)101 static void I8(store_log)(void *b, F90_Desc *s, int val)
102 {
103 dtype kind = TYPEKIND(s);
104 switch (kind) {
105 case __LOG1:
106 *(__LOG1_T *)b = val ? GET_DIST_TRUE_LOG1 : 0;
107 break;
108 case __LOG2:
109 *(__LOG2_T *)b = val ? GET_DIST_TRUE_LOG2 : 0;
110 break;
111 case __LOG4:
112 *(__LOG4_T *)b = val ? GET_DIST_TRUE_LOG4 : 0;
113 break;
114 case __LOG8:
115 *(__LOG8_T *)b = val ? GET_DIST_TRUE_LOG8 : 0;
116 break;
117 default:
118 __fort_abort("store_log: invalid argument type (logical expected)");
119 }
120 }
121
I8(store_element)122 static void I8(store_element)(void *ab, F90_Desc *as, int index, int val)
123 {
124 __INT_T *la;
125 __INT_T i;
126
127 if (F90_RANK_G(as) != 1)
128 __fort_abort("store_element: incorrect argument rank");
129
130 i = F90_DIM_LBOUND_G(as, 0) - 1 + index;
131 la = I8(__fort_local_address)(ab, as, &i);
132 if (la != NULL)
133 I8(store_int)(la, as, val);
134 }
135
I8(store_vector)136 static void I8(store_vector)(void *ab, F90_Desc *as, __INT_T *vector,
137 __INT_T veclen)
138 {
139 __INT_T *la;
140 __INT_T i;
141
142 if (F90_RANK_G(as) != 1)
143 __fort_abort("store_vector: incorrect argument rank");
144
145 for (i = F90_DIM_LBOUND_G(as, 0); --veclen >= 0; ++i) {
146 la = I8(__fort_local_address)(ab, as, &i);
147 if (la != NULL)
148 I8(store_int)(la, as, *vector);
149 ++vector;
150 }
151 }
152
I8(store_vector_int)153 static void I8(store_vector_int)(void *ab, F90_Desc *as, int *vector,
154 __INT_T veclen)
155 {
156 __INT_T *la;
157 __INT_T i;
158
159 if (F90_RANK_G(as) != 1)
160 __fort_abort("store_vector_int: incorrect argument rank");
161
162 for (i = F90_DIM_LBOUND_G(as, 0); --veclen >= 0; ++i) {
163 la = I8(__fort_local_address)(ab, as, &i);
164 if (la != NULL)
165 I8(store_int)(la, as, *vector);
166 ++vector;
167 }
168 }
169
ftnstrcpy(char * dst,size_t len,char * src)170 static void ftnstrcpy(char *dst, /* destination string, blank-filled */
171 size_t len, /* length of destination space */
172 char *src) /* null terminated source string */
173 {
174 char *end = dst + len;
175 while (dst < end && *src != '\0')
176 *dst++ = *src++;
177 while (dst < end)
178 *dst++ = ' ';
179 }
180
181 /* FIXME: still used ? */
182 /* hpf_library mapping inquiry routines */
ENTFTN(DIST_ALIGNMENT,dist_alignment)183 void ENTFTN(DIST_ALIGNMENT,
184 dist_alignment)(void *alignee_b, void *lb, void *ub, void *stride,
185 void *axis_map, void *identity_map, void *dynamic,
186 void *ncopies, F90_Desc *alignee, F90_Desc *lb_s,
187 F90_Desc *ub_s, F90_Desc *stride_s,
188 F90_Desc *axis_map_s, F90_Desc *identity_map_s,
189 F90_Desc *dynamic_s, F90_Desc *ncopies_s)
190 {
191 DECL_DIM_PTRS(ad);
192 proc *p;
193 procdim *pd;
194 __INT_T aextent, i, idm, ncp, px, rank, textent, vector[MAXDIMS];
195
196 rank = (F90_TAG_G(alignee) == __DESC) ? F90_RANK_G(alignee) : 0;
197
198 if (ISPRESENT(lb)) {
199 for (i = rank; --i >= 0;) {
200 SET_DIM_PTRS(ad, alignee, i);
201 vector[i] = DIST_DPTR_TSTRIDE_G(ad) * F90_DPTR_LBOUND_G(ad) +
202 DIST_DPTR_TOFFSET_G(ad) - DIST_DPTR_TLB_G(ad) + 1;
203 }
204 I8(store_vector)(lb, lb_s, vector, rank);
205 }
206 if (ISPRESENT(ub)) {
207 for (i = rank; --i >= 0;) {
208 SET_DIM_PTRS(ad, alignee, i);
209 vector[i] = DIST_DPTR_TSTRIDE_G(ad) * DPTR_UBOUND_G(ad) +
210 DIST_DPTR_TOFFSET_G(ad) - DIST_DPTR_TLB_G(ad) + 1;
211 }
212 I8(store_vector)(ub, ub_s, vector, rank);
213 }
214 if (ISPRESENT(stride)) {
215 for (i = rank; --i >= 0;) {
216 if (DFMT(alignee, i + 1) != DFMT_COLLAPSED) {
217 SET_DIM_PTRS(ad, alignee, i);
218 vector[i] = DIST_DPTR_TSTRIDE_G(ad);
219 } else {
220 vector[i] = 0;
221 }
222 }
223 I8(store_vector)(stride, stride_s, vector, rank);
224 }
225 if (ISPRESENT(axis_map)) {
226 for (i = rank; --i >= 0;) {
227 SET_DIM_PTRS(ad, alignee, i);
228 vector[i] = DIST_DPTR_TAXIS_G(ad);
229 }
230 I8(store_vector)(axis_map, axis_map_s, vector, rank);
231 }
232 if (ISPRESENT(identity_map)) {
233 idm = (rank == 0 || rank == F90_RANK_G(DIST_ALIGN_TARGET_G(alignee)));
234 for (i = rank; idm && --i >= 0;) {
235 SET_DIM_PTRS(ad, alignee, i);
236 idm = (DIST_DPTR_TAXIS_G(ad) == i + 1 && DIST_DPTR_TSTRIDE_G(ad) == 1 &&
237 F90_DPTR_LBOUND_G(ad) == DIST_DPTR_TLB_G(ad) &&
238 DPTR_UBOUND_G(ad) == DIST_DPTR_TUB_G(ad));
239 }
240 I8(store_log)(identity_map, identity_map_s, idm);
241 }
242 if (ISPRESENT(dynamic)) {
243 I8(store_log)(dynamic, dynamic_s, (rank > 0 && F90_FLAGS_G(alignee) & __DYNAMIC));
244 }
245 if (ISPRESENT(ncopies)) {
246 if (rank > 0) {
247 p = DIST_DIST_TARGET_G(alignee);
248 ncp = 1;
249 for (px = 0; px < p->rank; ++px) {
250 if (DIST_REPLICATED_G(alignee) >> px & 1) {
251 pd = &p->dim[px];
252 ncp *= pd->shape;
253 }
254 }
255 } else
256 ncp = GET_DIST_TCPUS;
257 I8(store_int)(ncopies, ncopies_s, ncp);
258 }
259 }
260
261 /* FIXME: still used */
ENTFTN(DIST_DISTRIBUTIONA,dist_distributiona)262 void ENTFTN(DIST_DISTRIBUTIONA, dist_distributiona)(
263 void *distributee_b, DCHAR(axis_type), void *axis_info, void *proc_rank,
264 void *proc_shape, void *plb, void *pub, void *pstride, void *low_shadow,
265 void *high_shadow, F90_Desc *distributee, F90_Desc *axis_type_s,
266 F90_Desc *axis_info_s, F90_Desc *proc_rank_s, F90_Desc *proc_shape_s,
267 F90_Desc *plb_s, F90_Desc *pub_s, F90_Desc *pstride_s,
268 F90_Desc *low_shadow_s, F90_Desc *high_shadow_s DCLEN64(axis_type))
269 {
270 DECL_HDR_PTRS(u);
271 DECL_DIM_PTRS(ud);
272 DECL_DIM_PTRS(dd);
273 proc *p;
274 procdim *pd;
275 __INT_T i, rank, vector[MAXDIMS];
276 char *src;
277 __CLEN_T len;
278
279 if (F90_TAG_G(distributee) == __DESC) {
280 u = DIST_ALIGN_TARGET_G(distributee);
281 p = DIST_DIST_TARGET_G(distributee);
282 rank = F90_RANK_G(u);
283 } else {
284 u = NULL;
285 p = NULL;
286 rank = 0;
287 }
288
289 if (ISPRESENTC(axis_type)) {
290 len = CLEN(axis_type);
291 for (i = rank; i > 0; --i) {
292 switch (DFMT(u, i)) {
293 case DFMT_COLLAPSED:
294 src = "COLLAPSED";
295 break;
296 case DFMT_BLOCK:
297 case DFMT_BLOCK_K:
298 src = "BLOCK";
299 break;
300 case DFMT_CYCLIC:
301 case DFMT_CYCLIC_K:
302 src = "CYCLIC";
303 break;
304 case DFMT_GEN_BLOCK:
305 src = "GEN_BLOCK";
306 break;
307 case DFMT_INDIRECT:
308 src = "INDIRECT";
309 break;
310 default:
311 __fort_abort("DIST_DISTRIBUTION: unsupported dist-format");
312 }
313 ftnstrcpy(CADR(axis_type) + (i - 1) * len, len, src);
314 }
315 }
316 if (ISPRESENT(axis_info)) {
317 for (i = rank; --i >= 0;) {
318 SET_DIM_PTRS(ud, u, i);
319 vector[i] = DIST_DPTR_BLOCK_G(ud);
320 }
321 I8(store_vector)(axis_info, axis_info_s, vector, rank);
322 }
323 if (ISPRESENT(proc_rank)) {
324 I8(store_int)(proc_rank, proc_rank_s, p != NULL ? p->rank : 0);
325 }
326 if (ISPRESENT(proc_shape) && p != NULL) {
327 for (i = p->rank; --i >= 0;) {
328 pd = &p->dim[i];
329 vector[i] = pd->shape;
330 }
331 I8(store_vector)(proc_shape, proc_shape_s, vector, p->rank);
332 }
333 if (ISPRESENT(plb)) {
334 for (i = rank; --i >= 0;) {
335 SET_DIM_PTRS(ud, u, i);
336 vector[i] = 1;
337 }
338 I8(store_vector)(plb, plb_s, vector, rank);
339 }
340 if (ISPRESENT(pub)) {
341 for (i = rank; --i >= 0;) {
342 SET_DIM_PTRS(ud, u, i);
343 vector[i] = DIST_DPTR_PSHAPE_G(ud);
344 }
345 I8(store_vector)(pub, pub_s, vector, rank);
346 }
347 if (ISPRESENT(pstride)) {
348 for (i = rank; --i >= 0;) {
349 SET_DIM_PTRS(ud, u, i);
350 vector[i] = DIST_DPTR_PSTRIDE_G(ud);
351 }
352 I8(store_vector)(pstride, pstride_s, vector, rank);
353 }
354
355 /* Return low_shadow and high_shadow values for the 'distributee'
356 argument. HPF 2 spec makes no sense where it says these should
357 come from the distributee's ultimate align target. */
358
359 rank = (F90_TAG_G(distributee) == __DESC) ? F90_RANK_G(distributee) : 0;
360
361 if (ISPRESENT(low_shadow)) {
362 for (i = rank; --i >= 0;) {
363 SET_DIM_PTRS(dd, distributee, i);
364 vector[i] = DIST_DPTR_NO_G(dd);
365 }
366 I8(store_vector)(low_shadow, low_shadow_s, vector, rank);
367 }
368 if (ISPRESENT(high_shadow)) {
369 for (i = rank; --i >= 0;) {
370 SET_DIM_PTRS(dd, distributee, i);
371 vector[i] = DIST_DPTR_PO_G(dd);
372 }
373 I8(store_vector)(high_shadow, high_shadow_s, vector, rank);
374 }
375 }
376 /* 32 bit CLEN version */
ENTFTN(DIST_DISTRIBUTION,dist_distribution)377 void ENTFTN(DIST_DISTRIBUTION, dist_distribution)(
378 void *distributee_b, DCHAR(axis_type), void *axis_info, void *proc_rank,
379 void *proc_shape, void *plb, void *pub, void *pstride, void *low_shadow,
380 void *high_shadow, F90_Desc *distributee, F90_Desc *axis_type_s,
381 F90_Desc *axis_info_s, F90_Desc *proc_rank_s, F90_Desc *proc_shape_s,
382 F90_Desc *plb_s, F90_Desc *pub_s, F90_Desc *pstride_s,
383 F90_Desc *low_shadow_s, F90_Desc *high_shadow_s DCLEN(axis_type))
384 {
385 ENTFTN(DIST_DISTRIBUTIONA, dist_distributiona)(distributee_b, CADR(axis_type),
386 axis_info, proc_rank, proc_shape, plb, pub, pstride, low_shadow,
387 high_shadow, distributee, axis_type_s, axis_info_s, proc_rank_s,
388 proc_shape_s, plb_s, pub_s, pstride_s, low_shadow_s, high_shadow_s,
389 (__CLEN_T)CLEN(axis_type));
390 }
391
392 /* FIXME: not used */
ENTFTN(DIST_TEMPLATEA,dist_templatea)393 void ENTFTN(DIST_TEMPLATEA,
394 dist_templatea)(void *alignee_b, void *template_rank, void *lb,
395 void *ub, DCHAR(axis_type), void *axis_info,
396 void *number_aligned, void *dynamic,
397 F90_Desc *alignee, F90_Desc *template_rank_s,
398 F90_Desc *lb_s, F90_Desc *ub_s, F90_Desc *axis_type_s,
399 F90_Desc *axis_info_s, F90_Desc *number_aligned_s,
400 F90_Desc *dynamic_s DCLEN64(axis_type))
401 {
402 DECL_HDR_PTRS(u);
403 DECL_HDR_PTRS(a);
404 DECL_DIM_PTRS(ud);
405 proc *p;
406 __INT_T i, rank, n_alnd, ux;
407 __INT_T alignee_axis[MAXDIMS], vector[MAXDIMS];
408 char *src;
409 __CLEN_T len;
410
411 if (F90_TAG_G(alignee) == __DESC) {
412 u = DIST_ALIGN_TARGET_G(alignee);
413 p = DIST_DIST_TARGET_G(alignee);
414 rank = F90_RANK_G(u);
415 for (i = rank; --i >= 0;)
416 alignee_axis[i] = 0;
417 for (i = F90_RANK_G(alignee); --i >= 0;) {
418 ux = DIST_DIM_TAXIS_G(alignee, i);
419 if (ux > 0)
420 alignee_axis[ux - 1] = i + 1;
421 }
422 } else
423 rank = 0;
424
425 if (ISPRESENT(template_rank)) {
426 I8(store_int)(template_rank, template_rank_s, rank);
427 }
428 if (ISPRESENT(lb)) {
429 for (i = rank; --i >= 0;) {
430 SET_DIM_PTRS(ud, u, i);
431 vector[i] = F90_DPTR_LBOUND_G(ud);
432 }
433 I8(store_vector)(lb, lb_s, vector, rank);
434 }
435 if (ISPRESENT(ub)) {
436 for (i = rank; --i >= 0;) {
437 SET_DIM_PTRS(ud, u, i);
438 vector[i] = DPTR_UBOUND_G(ud);
439 }
440 I8(store_vector)(ub, ub_s, vector, rank);
441 }
442 if (ISPRESENTC(axis_type)) {
443 len = CLEN(axis_type);
444 for (i = rank; --i >= 0;) {
445 if (alignee_axis[i] > 0)
446 src = "NORMAL";
447 else if (DIST_SINGLE_G(alignee) >> i & 1)
448 src = "SINGLE";
449 else
450 src = "REPLICATED";
451 ftnstrcpy(CADR(axis_type) + i * len, len, src);
452 }
453 }
454 if (ISPRESENT(axis_info)) {
455 for (i = rank; --i >= 0;) {
456 if (alignee_axis[i] > 0)
457 vector[i] = alignee_axis[i];
458 else if (DIST_SINGLE_G(alignee) >> i & 1)
459 vector[i] = DIST_INFO_G(alignee, i);
460 else {
461 SET_DIM_PTRS(ud, u, i);
462 vector[i] = (DIST_DPTR_PAXIS_G(ud) > 0) ? DIST_DPTR_PSHAPE_G(ud) : 1;
463 }
464 }
465 I8(store_vector)(axis_info, axis_info_s, vector, rank);
466 }
467 if (ISPRESENT(number_aligned)) {
468 if (!(F90_FLAGS_G(u) & __DYNAMIC)) {
469 __fort_abort(
470 "DIST_TEMPLATE: NUMBER_ALIGNED not supported for static align target");
471 }
472
473 n_alnd = 0;
474 if (rank > 0) {
475 if (u)
476 for (a = DIST_NEXT_ALIGNEE_G(u); a != NULL; a = DIST_NEXT_ALIGNEE_G(a)) {
477 ++n_alnd;
478 }
479 }
480 I8(store_int)(number_aligned, number_aligned_s, n_alnd);
481 }
482 if (ISPRESENT(dynamic)) {
483 I8(store_log)(dynamic, dynamic_s, rank > 0 && F90_FLAGS_G(u) & __DYNAMIC);
484 }
485 }
486 /* 32 bit CLEN version */
ENTFTN(DIST_TEMPLATE,dist_template)487 void ENTFTN(DIST_TEMPLATE,
488 dist_template)(void *alignee_b, void *template_rank, void *lb,
489 void *ub, DCHAR(axis_type), void *axis_info,
490 void *number_aligned, void *dynamic,
491 F90_Desc *alignee, F90_Desc *template_rank_s,
492 F90_Desc *lb_s, F90_Desc *ub_s, F90_Desc *axis_type_s,
493 F90_Desc *axis_info_s, F90_Desc *number_aligned_s,
494 F90_Desc *dynamic_s DCLEN(axis_type))
495 {
496 ENTFTN(DIST_TEMPLATEA, dist_templatea)(alignee_b, template_rank, lb, ub,
497 CADR(axis_type), axis_info, number_aligned, dynamic, alignee,
498 template_rank_s, lb_s, ub_s, axis_type_s, axis_info_s,
499 number_aligned_s, dynamic_s, (__CLEN_T)CLEN(axis_type));
500 }
501
ENTFTN(GLOBAL_ALIGNMENT,global_alignment)502 void ENTFTN(GLOBAL_ALIGNMENT,
503 global_alignment)(void *array_b, void *lb, void *ub, void *stride,
504 void *axis_map, void *identity_map, void *dynamic,
505 void *ncopies, F90_Desc *array_s, F90_Desc *lb_s,
506 F90_Desc *ub_s, F90_Desc *stride_s,
507 F90_Desc *axis_map_s, F90_Desc *identity_map_s,
508 F90_Desc *dynamic_s, F90_Desc *ncopies_s)
509 {
510 DECL_HDR_PTRS(alignee);
511 DECL_DIM_PTRS(ad);
512 proc *p;
513 __INT_T i, idm, n, rank, vector[MAXDIMS];
514
515 if (F90_TAG_G(array_s) == __DESC) {
516 alignee = DIST_ACTUAL_ARG_G(array_s);
517 if (alignee == NULL)
518 __fort_abort("GLOBAL_ALIGNMENT: array is not associated"
519 " with global actual argument");
520 rank = F90_RANK_G(alignee);
521 } else
522 rank = 0;
523
524 if (ISPRESENT(lb)) {
525 for (i = rank; --i >= 0;) {
526 SET_DIM_PTRS(ad, alignee, i);
527 vector[i] = DIST_DPTR_TSTRIDE_G(ad) * F90_DPTR_LBOUND_G(ad) +
528 DIST_DPTR_TOFFSET_G(ad) - DIST_DPTR_TLB_G(ad) + 1;
529 }
530 I8(store_vector)(lb, lb_s, vector, rank);
531 }
532 if (ISPRESENT(ub)) {
533 for (i = rank; --i >= 0;) {
534 SET_DIM_PTRS(ad, alignee, i);
535 vector[i] = DIST_DPTR_TSTRIDE_G(ad) * DPTR_UBOUND_G(ad) +
536 DIST_DPTR_TOFFSET_G(ad) - DIST_DPTR_TLB_G(ad) + 1;
537 }
538 I8(store_vector)(ub, ub_s, vector, rank);
539 }
540 if (ISPRESENT(stride)) {
541 for (i = rank; --i >= 0;) {
542 SET_DIM_PTRS(ad, alignee, i);
543 vector[i] = DIST_DPTR_TSTRIDE_G(ad);
544 }
545 I8(store_vector)(stride, stride_s, vector, rank);
546 }
547 if (ISPRESENT(axis_map)) {
548 for (i = rank; --i >= 0;) {
549 SET_DIM_PTRS(ad, alignee, i);
550 vector[i] = DIST_DPTR_TAXIS_G(ad);
551 }
552 I8(store_vector)(axis_map, axis_map_s, vector, rank);
553 }
554 if (ISPRESENT(identity_map)) {
555 idm = (rank == 0 || rank == F90_TAG_G(DIST_ALIGN_TARGET_G(alignee)));
556 for (i = rank; idm && --i >= 0;) {
557 SET_DIM_PTRS(ad, alignee, i);
558 idm = (DIST_DPTR_TAXIS_G(ad) == i + 1 && DIST_DPTR_TSTRIDE_G(ad) == 1 &&
559 F90_DPTR_LBOUND_G(ad) == DIST_DPTR_TLB_G(ad) &&
560 DPTR_UBOUND_G(ad) == DIST_DPTR_TUB_G(ad));
561 }
562 I8(store_log)(identity_map, identity_map_s, idm);
563 }
564 if (ISPRESENT(dynamic)) {
565 I8(store_log)(dynamic, dynamic_s, rank > 0 && F90_FLAGS_G(alignee) & __DYNAMIC);
566 }
567 if (ISPRESENT(ncopies)) {
568 if (rank > 0) {
569 n = 1;
570 p = DIST_DIST_TARGET_G(alignee);
571 for (i = p->rank; --i >= 0;) {
572 if (DIST_REPLICATED_G(alignee) >> i & 1)
573 n *= p->dim[i].shape;
574 }
575 } else
576 n = GET_DIST_TCPUS;
577 I8(store_int)(ncopies, ncopies_s, n);
578 }
579 }
580
ENTFTN(GLOBAL_DISTRIBUTIONA,global_distributiona)581 void ENTFTN(GLOBAL_DISTRIBUTIONA, global_distributiona)(
582 void *array_b, DCHAR(axis_type), void *axis_info, void *proc_rank,
583 void *proc_shape, void *plb, void *pub, void *pstride, void *low_shadow,
584 void *high_shadow, F90_Desc *array_s, F90_Desc *axis_type_s,
585 F90_Desc *axis_info_s, F90_Desc *proc_rank_s, F90_Desc *proc_shape_s,
586 F90_Desc *plb_s, F90_Desc *pub_s, F90_Desc *pstride_s,
587 F90_Desc *low_shadow_s, F90_Desc *high_shadow_s DCLEN(axis_type))
588 {
589 DECL_HDR_PTRS(u);
590 DECL_HDR_PTRS(distributee);
591 DECL_DIM_PTRS(ud);
592 DECL_DIM_PTRS(dd);
593 proc *p;
594 procdim *pd;
595 __INT_T i, rank, vector[MAXDIMS];
596 char *src;
597 __CLEN_T len;
598
599 if (F90_TAG_G(array_s) == __DESC) {
600 distributee = DIST_ACTUAL_ARG_G(array_s);
601 if (distributee == NULL)
602 __fort_abort("GLOBAL_DISTRIBUTION: array is not associated"
603 " with global actual argument");
604 u = DIST_ALIGN_TARGET_G(distributee);
605 p = DIST_DIST_TARGET_G(distributee);
606 rank = F90_RANK_G(u);
607 } else {
608 distributee = NULL;
609 u = NULL;
610 p = NULL;
611 rank = 0;
612 }
613
614 if (ISPRESENTC(axis_type)) {
615 len = CLEN(axis_type);
616 for (i = rank; i > 0; --i) {
617 switch (DFMT(u, i)) {
618 case DFMT_COLLAPSED:
619 src = "COLLAPSED";
620 break;
621 case DFMT_BLOCK:
622 case DFMT_BLOCK_K:
623 src = "BLOCK";
624 break;
625 case DFMT_CYCLIC:
626 case DFMT_CYCLIC_K:
627 src = "CYCLIC";
628 break;
629 case DFMT_GEN_BLOCK:
630 src = "GEN_BLOCK";
631 break;
632 case DFMT_INDIRECT:
633 src = "INDIRECT";
634 break;
635 default:
636 __fort_abort("GLOBAL_DISTRIBUTION: unsupported dist-format");
637 }
638 ftnstrcpy(CADR(axis_type) + (i - 1) * len, len, src);
639 }
640 }
641 if (ISPRESENT(axis_info)) {
642 for (i = rank; --i >= 0;) {
643 SET_DIM_PTRS(ud, u, i);
644 vector[i] = DIST_DPTR_BLOCK_G(ud);
645 }
646 I8(store_vector)(axis_info, axis_info_s, vector, rank);
647 }
648 if (ISPRESENT(proc_rank)) {
649 I8(store_int)(proc_rank, proc_rank_s, p != NULL ? p->rank : 0);
650 }
651 if (ISPRESENT(proc_shape) && p != NULL) {
652 for (i = p->rank; --i >= 0;) {
653 pd = &p->dim[i];
654 vector[i] = pd->shape;
655 }
656 I8(store_vector)(proc_shape, proc_shape_s, vector, p->rank);
657 }
658 if (ISPRESENT(plb)) {
659 for (i = rank; --i >= 0;) {
660 SET_DIM_PTRS(ud, u, i);
661 vector[i] = 1;
662 }
663 I8(store_vector)(plb, plb_s, vector, rank);
664 }
665 if (ISPRESENT(pub)) {
666 for (i = rank; --i >= 0;) {
667 SET_DIM_PTRS(ud, u, i);
668 vector[i] = DIST_DPTR_PSHAPE_G(ud);
669 }
670 I8(store_vector)(pub, pub_s, vector, rank);
671 }
672 if (ISPRESENT(pstride)) {
673 for (i = rank; --i >= 0;) {
674 SET_DIM_PTRS(ud, u, i);
675 vector[i] = DIST_DPTR_PSTRIDE_G(ud);
676 }
677 I8(store_vector)(pstride, pstride_s, vector, rank);
678 }
679
680 /* Return low_shadow and high_shadow values for the 'distributee'
681 argument. HPF 2 spec makes no sense where it says these should
682 come from the distributee's ultimate align target. */
683
684 rank = (distributee != NULL && F90_TAG_G(distributee) == __DESC)
685 ? F90_RANK_G(distributee)
686 : 0;
687
688 if (ISPRESENT(low_shadow)) {
689 for (i = rank; --i >= 0;) {
690 SET_DIM_PTRS(dd, distributee, i);
691 vector[i] = DIST_DPTR_NO_G(dd);
692 }
693 I8(store_vector)(low_shadow, low_shadow_s, vector, rank);
694 }
695 if (ISPRESENT(high_shadow)) {
696 for (i = rank; --i >= 0;) {
697 SET_DIM_PTRS(dd, distributee, i);
698 vector[i] = DIST_DPTR_PO_G(dd);
699 }
700 I8(store_vector)(high_shadow, high_shadow_s, vector, rank);
701 }
702 }
703 /* 32 bit CLEN version */
ENTFTN(GLOBAL_DISTRIBUTION,global_distribution)704 void ENTFTN(GLOBAL_DISTRIBUTION, global_distribution)(
705 void *array_b, DCHAR(axis_type), void *axis_info, void *proc_rank,
706 void *proc_shape, void *plb, void *pub, void *pstride, void *low_shadow,
707 void *high_shadow, F90_Desc *array_s, F90_Desc *axis_type_s,
708 F90_Desc *axis_info_s, F90_Desc *proc_rank_s, F90_Desc *proc_shape_s,
709 F90_Desc *plb_s, F90_Desc *pub_s, F90_Desc *pstride_s,
710 F90_Desc *low_shadow_s, F90_Desc *high_shadow_s DCLEN(axis_type))
711 {
712 ENTFTN(GLOBAL_DISTRIBUTIONA, global_distributiona)(array_b, CADR(axis_type),
713 axis_info, proc_rank, proc_shape, plb, pub, pstride, low_shadow,
714 high_shadow, array_s, axis_type_s, axis_info_s, proc_rank_s,
715 proc_shape_s, plb_s, pub_s, pstride_s, low_shadow_s, high_shadow_s,
716 (__CLEN_T)CLEN(axis_type));
717 }
718
ENTFTN(GLOBAL_TEMPLATEA,global_templatea)719 void ENTFTN(GLOBAL_TEMPLATEA, global_templatea)(
720 void *array_b, void *template_rank, void *lb, void *ub, DCHAR(axis_type),
721 void *axis_info, void *number_aligned, void *dynamic, F90_Desc *array_s,
722 F90_Desc *template_rank_s, F90_Desc *lb_s, F90_Desc *ub_s,
723 F90_Desc *axis_type_s, F90_Desc *axis_info_s, F90_Desc *number_aligned_s,
724 F90_Desc *dynamic_s DCLEN64(axis_type))
725 {
726 DECL_HDR_PTRS(u);
727 DECL_HDR_PTRS(alignee);
728 DECL_HDR_PTRS(a);
729 DECL_DIM_PTRS(ud);
730 proc *p;
731 __INT_T i, rank, n_alnd, ux;
732 __INT_T alignee_axis[MAXDIMS], vector[MAXDIMS];
733 char *src;
734 __CLEN_T len;
735
736 if (F90_TAG_G(array_s) == __DESC) {
737 alignee = DIST_ACTUAL_ARG_G(array_s);
738 if (alignee == NULL)
739 __fort_abort("GLOBAL_TEMPLATE: array is not associated"
740 " with global actual argument");
741 u = DIST_ALIGN_TARGET_G(alignee);
742 p = DIST_DIST_TARGET_G(alignee);
743 rank = F90_RANK_G(u);
744 for (i = rank; --i >= 0;)
745 alignee_axis[i] = 0;
746 for (i = F90_RANK_G(alignee); --i >= 0;) {
747 ux = DIST_DIM_TAXIS_G(alignee, i);
748 if (ux > 0)
749 alignee_axis[ux - 1] = i + 1;
750 }
751 } else
752 rank = 0;
753
754 if (ISPRESENT(template_rank)) {
755 I8(store_int)(template_rank, template_rank_s, rank);
756 }
757 if (ISPRESENT(lb)) {
758 for (i = rank; --i >= 0;) {
759 SET_DIM_PTRS(ud, u, i);
760 vector[i] = F90_DPTR_LBOUND_G(ud);
761 }
762 I8(store_vector)(lb, lb_s, vector, rank);
763 }
764 if (ISPRESENT(ub)) {
765 for (i = rank; --i >= 0;) {
766 SET_DIM_PTRS(ud, u, i);
767 vector[i] = DPTR_UBOUND_G(ud);
768 }
769 I8(store_vector)(ub, ub_s, vector, rank);
770 }
771 if (ISPRESENTC(axis_type)) {
772 len = CLEN(axis_type);
773 for (i = rank; --i >= 0;) {
774 if (alignee_axis[i] > 0)
775 src = "NORMAL";
776 else if (DIST_SINGLE_G(alignee) >> i & 1)
777 src = "SINGLE";
778 else
779 src = "REPLICATED";
780 ftnstrcpy(CADR(axis_type) + i * len, len, src);
781 }
782 }
783 if (ISPRESENT(axis_info)) {
784 for (i = rank; --i >= 0;) {
785 if (alignee_axis[i] > 0)
786 vector[i] = alignee_axis[i];
787 else if (DIST_SINGLE_G(alignee) >> i & 1)
788 vector[i] = DIST_INFO_G(alignee, i);
789 else {
790 SET_DIM_PTRS(ud, u, i);
791 vector[i] = (DIST_DPTR_PAXIS_G(ud) > 0) ? DIST_DPTR_PSHAPE_G(ud) : 1;
792 }
793 }
794 I8(store_vector)(axis_info, axis_info_s, vector, rank);
795 }
796 if (ISPRESENT(number_aligned)) {
797 n_alnd = 0;
798 if (rank > 0) {
799 for (a = u; a != NULL; a = DIST_NEXT_ALIGNEE_G(a))
800 ++n_alnd;
801 }
802 I8(store_int)(number_aligned, number_aligned_s, n_alnd);
803 }
804 if (ISPRESENT(dynamic)) {
805 I8(store_log)(dynamic, dynamic_s, rank > 0 && F90_FLAGS_G(u) & __DYNAMIC);
806 }
807 }
808 /* 32 bit CLEN version */
ENTFTN(GLOBAL_TEMPLATE,global_template)809 void ENTFTN(GLOBAL_TEMPLATE, global_template)(
810 void *array_b, void *template_rank, void *lb, void *ub, DCHAR(axis_type),
811 void *axis_info, void *number_aligned, void *dynamic, F90_Desc *array_s,
812 F90_Desc *template_rank_s, F90_Desc *lb_s, F90_Desc *ub_s,
813 F90_Desc *axis_type_s, F90_Desc *axis_info_s, F90_Desc *number_aligned_s,
814 F90_Desc *dynamic_s DCLEN(axis_type))
815 {
816 ENTFTN(GLOBAL_TEMPLATEA, global_templatea)(array_b, template_rank, lb, ub,
817 CADR(axis_type), axis_info, number_aligned, dynamic, array_s,
818 template_rank_s, lb_s, ub_s, axis_type_s, axis_info_s,
819 number_aligned_s, dynamic_s, (__CLEN_T)CLEN(axis_type));
820 }
821
ENTFTN(GLOBAL_LBOUND,global_lbound)822 void ENTFTN(GLOBAL_LBOUND, global_lbound)(void *lbound_b, void *array_b,
823 void *dim_b, F90_Desc *lbound_s,
824 F90_Desc *array_s, F90_Desc *dim_s)
825 {
826 DECL_HDR_PTRS(g);
827 __INT_T i, dim, rank, vector[MAXDIMS];
828
829 if (F90_TAG_G(array_s) == __DESC) {
830 g = DIST_ACTUAL_ARG_G(array_s);
831 if (g == NULL)
832 __fort_abort("GLOBAL_LBOUND: array is not associated"
833 " with global actual argument");
834 rank = F90_RANK_G(g);
835 } else
836 rank = 0;
837
838 if (ISPRESENT(dim_b)) {
839 dim = I8(fetch_int)(dim_b, dim_s);
840 if (dim < 1 || dim > rank)
841 __fort_abort("GLOBAL_LBOUND: invalid dim");
842 I8(store_int)(lbound_b, lbound_s, F90_DIM_LBOUND_G(g, dim - 1));
843 } else {
844 for (i = rank; --i >= 0;)
845 vector[i] = F90_DIM_LBOUND_G(g, i);
846 I8(store_vector)(lbound_b, lbound_s, vector, rank);
847 }
848 }
849
ENTFTN(GLOBAL_SHAPE,global_shape)850 void ENTFTN(GLOBAL_SHAPE, global_shape)(void *shape_b, void *source_b,
851 F90_Desc *shape_s, F90_Desc *source_s)
852 {
853 DECL_HDR_PTRS(g);
854 DECL_DIM_PTRS(gd);
855 __INT_T i, extent, rank, vector[MAXDIMS];
856
857 if (F90_TAG_G(source_s) == __DESC) {
858 g = DIST_ACTUAL_ARG_G(source_s);
859 if (g == NULL)
860 __fort_abort("GLOBAL_SHAPE: source is not associated with"
861 " global actual argument");
862 rank = F90_RANK_G(g);
863 } else
864 rank = 0;
865
866 for (i = rank; --i >= 0;) {
867 SET_DIM_PTRS(gd, g, i);
868 extent = F90_DPTR_EXTENT_G(gd);
869 if (extent < 0)
870 extent = 0;
871 vector[i] = extent;
872 }
873 I8(store_vector)(shape_b, shape_s, vector, rank);
874 }
875
ENTFTN(GLOBAL_SIZE,global_size)876 void ENTFTN(GLOBAL_SIZE, global_size)(void *size_b, void *array_b, void *dim_b,
877 F90_Desc *size_s, F90_Desc *array_s,
878 F90_Desc *dim_s)
879 {
880 DECL_HDR_PTRS(g);
881 DECL_DIM_PTRS(gd);
882 __INT_T i, dim, rank, size;
883
884 if (F90_TAG_G(array_s) == __DESC) {
885 g = DIST_ACTUAL_ARG_G(array_s);
886 if (g == NULL)
887 __fort_abort("GLOBAL_SIZE: array is not associated with"
888 " global actual argument");
889 rank = F90_RANK_G(g);
890 SET_DIM_PTRS(gd, g, 0);
891 } else
892 rank = 0;
893
894 if (ISPRESENT(dim_b)) {
895 dim = I8(fetch_int)(dim_b, dim_s);
896 if (dim < 1 || dim > rank)
897 __fort_abort("GLOBAL_SIZE: invalid dim");
898 SET_DIM_PTRS(gd, g, dim - 1);
899 size = F90_DPTR_EXTENT_G(gd);
900 if (size < 0)
901 size = 0;
902 } else if (rank > 0)
903 size = F90_GSIZE_G(g);
904 else
905 size = 1;
906 I8(store_int)(size_b, size_s, size);
907 }
908
ENTFTN(GLOBAL_UBOUND,global_ubound)909 void ENTFTN(GLOBAL_UBOUND, global_ubound)(void *ubound_b, void *array_b,
910 void *dim_b, F90_Desc *ubound_s,
911 F90_Desc *array_s, F90_Desc *dim_s)
912 {
913 DECL_HDR_PTRS(g);
914 __INT_T i, dim, rank, vector[MAXDIMS];
915
916 if (F90_TAG_G(array_s) == __DESC) {
917 g = DIST_ACTUAL_ARG_G(array_s);
918 if (g == NULL)
919 __fort_abort("GLOBAL_UBOUND: array is not associated with"
920 "global actual argument");
921 rank = F90_RANK_G(g);
922 } else
923 rank = 0;
924
925 if (ISPRESENT(dim_b)) {
926 dim = I8(fetch_int)(dim_b, dim_s);
927 if (dim < 1 || dim > rank)
928 __fort_abort("GLOBAL_UBOUND: invalid dim");
929 I8(store_int)(ubound_b, ubound_s, DIM_UBOUND_G(g, dim - 1));
930 } else {
931 for (i = rank; --i >= 0;)
932 vector[i] = DIM_UBOUND_G(g, i);
933 I8(store_vector)(ubound_b, ubound_s, vector, rank);
934 }
935 }
936
ENTFTN(ABSTRACT_TO_PHYSICAL,abstract_to_physical)937 void ENTFTN(ABSTRACT_TO_PHYSICAL,
938 abstract_to_physical)(void *array_b, void *index_b, void *proc_b,
939 F90_Desc *array_s, F90_Desc *index_s,
940 F90_Desc *proc_s)
941 {
942 DECL_HDR_PTRS(g);
943 proc *p;
944 procdim *pd;
945 __INT_T i, index[MAXDIMS], proc;
946
947 if (F90_TAG_G(array_s) != __DESC)
948 __fort_abort("ABSTRACT_TO_PHYSICAL: argument must be array");
949
950 g = DIST_ACTUAL_ARG_G(array_s);
951 if (g == NULL)
952 __fort_abort("ABSTRACT_TO_PHYSICAL: array is not associated"
953 " with global actual argument");
954
955 p = DIST_DIST_TARGET_G(g);
956
957 I8(fetch_vector)(index_b, index_s, index, p->rank);
958
959 proc = p->base;
960 for (i = p->rank; --i >= 0;) {
961 pd = &p->dim[i];
962 if (index[i] < 1 || index[i] > pd->shape)
963 __fort_abort("ABSTRACT_TO_PHYSICAL: invalid processor coordinate");
964 proc += pd->stride * (index[i] - 1);
965 }
966 I8(store_int)(proc_b, proc_s, proc);
967 }
968
ENTFTN(PHYSICAL_TO_ABSTRACT,physical_to_abstract)969 void ENTFTN(PHYSICAL_TO_ABSTRACT,
970 physical_to_abstract)(void *array_b, void *proc_b, void *index_b,
971 F90_Desc *array_s, F90_Desc *proc_s,
972 F90_Desc *index_s)
973 {
974 DECL_HDR_PTRS(g);
975 proc *p;
976 procdim *pd;
977 __INT_T i, index[MAXDIMS], proc;
978
979 if (F90_TAG_G(array_s) != __DESC)
980 __fort_abort("PHYSICAL_TO_ABSTRACT: argument must be array");
981
982 g = DIST_ACTUAL_ARG_G(array_s);
983 if (g == NULL)
984 __fort_abort("PHYSICAL_TO_ABSTRACT: array is not associated"
985 " with global actual argument");
986
987 p = DIST_DIST_TARGET_G(g);
988
989 proc = I8(fetch_int)(proc_b, proc_s);
990
991 proc -= p->base;
992 if (proc < 0 || proc >= p->size)
993 __fort_abort("PHYSICAL_TO_ABSTRACT: invalid processor number");
994
995 for (i = 0; i < p->rank; ++i) {
996 pd = &p->dim[i];
997 RECIP_DIVMOD(&proc, &index[i], proc, pd->shape);
998 index[i]++;
999 }
1000 I8(store_vector)(index_b, index_s, index, p->rank);
1001 }
1002
1003 /* Translate local indices to global indices */
1004
ENTFTN(LOCAL_TO_GLOBAL,local_to_global)1005 void ENTFTN(LOCAL_TO_GLOBAL,
1006 local_to_global)(void *array_b, void *l_index_b, void *g_index_b,
1007 F90_Desc *array_s, F90_Desc *l_index_s,
1008 F90_Desc *g_index_s)
1009 {
1010 DECL_HDR_PTRS(gs);
1011 DECL_DIM_PTRS(gsd);
1012 DECL_DIM_PTRS(asd);
1013 __INT_T i, j, local, gof, procno, *procs;
1014 __INT_T index[MAXDIMS], pcoord[MAXDIMS];
1015 __INT_T lb, ub, lof;
1016 __INT_T lboffset, adjindex, cyclenum, cyclepos, gstride;
1017
1018 if (F90_TAG_G(array_s) != __DESC)
1019 __fort_abort("LOCAL_TO_GLOBAL: argument must be array");
1020
1021 gs = DIST_ACTUAL_ARG_G(array_s);
1022 if (gs == NULL || F90_TAG_G(gs) != __DESC)
1023 __fort_abort("LOCAL_TO_GLOBAL: array is not associated with"
1024 " global actual argument");
1025 #if defined(DEBUG)
1026 if (F90_RANK_G(gs) != F90_RANK_G(array_s))
1027 __fort_abort("LOCAL_TO_GLOBAL: global vs. local rank mismatch");
1028 #endif
1029
1030 /* get the local index vector */
1031
1032 I8(fetch_vector)(l_index_b, l_index_s, index, F90_RANK_G(gs));
1033
1034 /* translate local array indices to global array indices */
1035
1036 for (i = 1; i <= F90_RANK_G(gs); ++i) { /* iterate through dimensions */
1037
1038 SET_DIM_PTRS(asd, array_s, i - 1);
1039 SET_DIM_PTRS(gsd, gs, i - 1);
1040
1041 /* index must be within local array bounds */
1042
1043 if (index[i - 1] < F90_DPTR_LBOUND_G(asd) ||
1044 index[i - 1] > DPTR_UBOUND_G(asd)) {
1045 __fort_abort("LOCAL_TO_GLOBAL: index outside local array bounds\n");
1046 }
1047
1048 switch (DFMT(gs, i)) {
1049 case DFMT_CYCLIC:
1050 case DFMT_CYCLIC_K:
1051
1052 if (DIST_DPTR_TSTRIDE_G(gsd) != 1) {
1053
1054 int ii, startblocks, off;
1055 int elem_per_cycle, elem, my_cycle_lb, my_cycle_ub, first;
1056 int tstride, abs_tstride, gblock, pcoord, lbound;
1057
1058 tstride = DIST_DPTR_TSTRIDE_G(gsd);
1059 abs_tstride = Abs(tstride);
1060 gblock = DIST_DPTR_BLOCK_G(gsd);
1061 pcoord = DIST_DPTR_PCOORD_G(gsd);
1062 lbound = F90_DPTR_LBOUND_G(gsd);
1063 off = DIST_DPTR_TOFFSET_G(gsd);
1064 first = (lbound * tstride + off) - 1;
1065 elem = first + 1;
1066
1067 if (tstride < 0) {
1068
1069 int start_cpu, ext, text, partialblocks, tlb, tub, cpus;
1070
1071 tlb = DIST_DPTR_TLB_G(gsd);
1072
1073 tub = DIST_DPTR_TUB_G(gsd);
1074
1075 ext = elem - tlb + 1;
1076
1077 text = tub - tlb + 1;
1078
1079 cpus = Min(DIST_DPTR_PSHAPE_G(gsd), Ceil(text, gblock));
1080
1081 elem_per_cycle = (gblock * cpus);
1082
1083 partialblocks = (ext % elem_per_cycle);
1084
1085 if (!partialblocks) {
1086 start_cpu = cpus - 1;
1087 startblocks = gblock * Abs(pcoord - start_cpu);
1088 } else if (partialblocks <= gblock) {
1089 start_cpu = 0;
1090 startblocks = partialblocks * Abs(pcoord - start_cpu);
1091 if (!startblocks)
1092 startblocks = partialblocks - gblock;
1093 } else {
1094
1095 RECIP_DIV(&start_cpu, partialblocks, DIST_DPTR_BLOCK_G(gsd));
1096
1097 if (start_cpu < 0)
1098 start_cpu += cpus;
1099 else if (start_cpu >= cpus)
1100 start_cpu -= cpus;
1101
1102 startblocks = Abs(pcoord - start_cpu);
1103 startblocks *= (partialblocks - gblock);
1104 }
1105
1106 elem = tub - elem + 1;
1107 first = elem - 1;
1108
1109 } else {
1110 elem_per_cycle = DIST_DPTR_CYCLE_G(gsd);
1111 startblocks = pcoord * gblock;
1112 }
1113
1114 my_cycle_lb = (lbound + startblocks);
1115
1116 if (my_cycle_lb > lbound) {
1117 while (elem > my_cycle_lb)
1118 my_cycle_lb += elem_per_cycle;
1119 }
1120
1121 my_cycle_ub = my_cycle_lb + (gblock - 1);
1122
1123 elem -= abs_tstride;
1124 for (ii = F90_DPTR_LBOUND_G(asd); ii <= index[i - 1];) {
1125 if (elem > my_cycle_ub) {
1126 my_cycle_lb += elem_per_cycle;
1127 my_cycle_ub += elem_per_cycle;
1128 } else
1129 elem += abs_tstride;
1130
1131 if (elem >= my_cycle_lb && elem <= my_cycle_ub) {
1132 ++ii;
1133 }
1134 }
1135
1136 index[i - 1] =
1137 (elem - first) / abs_tstride + (elem - first) % abs_tstride;
1138
1139 break;
1140 }
1141
1142 if (DIST_DPTR_OLB_G(gsd) == F90_DPTR_LBOUND_G(gsd)) { /* First element */
1143 lboffset = 0;
1144 } else {
1145 lboffset = 0;
1146 }
1147 adjindex = index[i - 1] - F90_DPTR_LBOUND_G(asd) + lboffset;
1148 RECIP_DIVMOD(&cyclenum, &cyclepos, adjindex, DIST_DPTR_BLOCK_G(gsd));
1149 index[i - 1] = cyclenum * DIST_DPTR_CYCLE_G(gsd) + cyclepos +
1150 DIST_DPTR_OLB_G(gsd) - lboffset;
1151
1152 break;
1153
1154 default: /* block */
1155 index[i - 1] += DIST_DPTR_OLB_G(gsd) - F90_DPTR_LBOUND_G(asd);
1156 }
1157 }
1158
1159 /* return the global index vector */
1160
1161 I8(store_vector)(g_index_b, g_index_s, index, F90_RANK_G(gs));
1162 }
1163
1164 /* Translate global indices to local indices */
1165
ENTFTN(GLOBAL_TO_LOCAL,global_to_local)1166 void ENTFTN(GLOBAL_TO_LOCAL,
1167 global_to_local)(void *array_b, void *g_index_b, void *l_index_b,
1168 void *local_b, void *ncopies_b, void *procs_b,
1169 F90_Desc *array_s, F90_Desc *g_index_s,
1170 F90_Desc *l_index_s, F90_Desc *local_s,
1171 F90_Desc *ncopies_s, F90_Desc *procs_s)
1172 {
1173 DECL_DIM_PTRS(asd); /* local array dimensions */
1174 DECL_HDR_PTRS(gs); /* global section */
1175 DECL_DIM_PTRS(gsd); /* global section dimensions */
1176 proc *p;
1177 repl_t repl; /* replication descriptor */
1178 __INT_T i, j, local, lof, n, procno;
1179 __INT_T *procs;
1180 __INT_T gindex[MAXDIMS], lindex[MAXDIMS], pcoord[MAXDIMS];
1181
1182 if (F90_TAG_G(array_s) != __DESC)
1183 __fort_abort("GLOBAL_TO_LOCAL: argument must be array");
1184 gs = DIST_ACTUAL_ARG_G(array_s);
1185 if (gs == NULL || F90_TAG_G(gs) != __DESC)
1186 __fort_abort("GLOBAL_TO_LOCAL: array is not associated with"
1187 " global actual argument");
1188 #if defined(DEBUG)
1189 if (F90_RANK_G(gs) != F90_RANK_G(array_s))
1190 __fort_abort("GLOBAL_TO_LOCAL: global vs. local rank mismatch");
1191 #endif
1192
1193 /* get the global index vector */
1194
1195 I8(fetch_vector)(g_index_b, g_index_s, gindex, F90_RANK_G(gs));
1196
1197 /* check if element is local */
1198
1199 local = I8(__fort_islocal)(gs, gindex);
1200
1201 if (local && ISPRESENT(l_index_b)) {
1202 for (i = F90_RANK_G(gs); i > 0; --i) {
1203 SET_DIM_PTRS(asd, array_s, i - 1);
1204 SET_DIM_PTRS(gsd, gs, i - 1);
1205
1206 switch (DFMT(gs, i)) {
1207 case DFMT_CYCLIC:
1208 case DFMT_CYCLIC_K: {
1209
1210 __INT_T aolb, aoub;
1211
1212 aolb = DIST_DPTR_OLB_G(asd);
1213 aoub = DIST_DPTR_OUB_G(asd);
1214
1215 /* compute local offset for cyclic distribution */
1216
1217 j = DIST_DPTR_TSTRIDE_G(gsd) * gindex[i - 1] + DIST_DPTR_TOFFSET_G(gsd) -
1218 DIST_DPTR_CLB_G(gsd);
1219 j = Abs(j);
1220 RECIP_DIV(&j, j, DIST_DPTR_CYCLE_G(gsd));
1221 lof = j * DIST_DPTR_COFSTR_G(gsd);
1222
1223 lindex[i - 1] = F90_DPTR_SSTRIDE_G(gsd) * gindex[i - 1] +
1224 F90_DPTR_SOFFSET_G(gsd) - lof -
1225 (DIST_DPTR_OLB_G(gsd) - aolb);
1226
1227 while (lindex[i - 1] > aoub) {
1228 lindex[i - 1] -= (DIST_DPTR_CYCLE_G(gsd) - DIST_DPTR_BLOCK_G(gsd));
1229 }
1230
1231 while (lindex[i - 1] < aolb) {
1232 lindex[i - 1] += (aoub - aolb + 1);
1233 }
1234 break;
1235 }
1236
1237 default:
1238 /* block or unmapped: subtract the difference between
1239 global and local owned bounds */
1240 lindex[i - 1] =
1241 gindex[i - 1] - (DIST_DPTR_OLB_G(gsd) - DIST_DPTR_OLB_G(asd));
1242 }
1243 }
1244 I8(store_vector)(l_index_b, l_index_s, lindex, F90_RANK_G(gs));
1245 }
1246
1247 if (ISPRESENT(local_b))
1248 I8(store_log)(local_b, local_s, local);
1249
1250 /* if needed, get replication info */
1251
1252 if (ISPRESENT(ncopies_b) || ISPRESENT(procs_b))
1253 I8(__fort_describe_replication)(gs, &repl);
1254
1255 if (ISPRESENT(ncopies_b))
1256 I8(store_int)(ncopies_b, ncopies_s, repl.ncopies);
1257
1258 if (ISPRESENT(procs_b)) {
1259 procno = I8(__fort_owner)(gs, gindex);
1260 if (repl.ncopies == 1)
1261 I8(store_vector)(procs_b, procs_s, &procno, 1);
1262 else {
1263 procs = (__INT_T *)__fort_malloc(repl.ncopies * sizeof(__INT_T));
1264 for (i = repl.ndim; --i >= 0;)
1265 pcoord[i] = 0;
1266 i = j = 0;
1267 while (j < repl.ndim) {
1268 if (pcoord[j] < repl.pcnt[j]) {
1269 procs[i++] = procno;
1270 procno += repl.pstr[j];
1271 ++pcoord[j];
1272 j = 0;
1273 } else {
1274 procno -= repl.pcnt[j] * repl.pstr[j];
1275 pcoord[j++] = 0;
1276 }
1277 }
1278 #if defined(DEBUG)
1279 if (i != repl.ncopies)
1280 __fort_abort("GLOBAL_TO_LOCAL: replication info incorrect");
1281 #endif
1282 I8(store_vector)(procs_b, procs_s, procs, repl.ncopies);
1283 __fort_free(procs);
1284 }
1285 }
1286 }
1287
1288 /* Return the number of non-empty blocks in all or a specified dimension. */
1289
ENTFTN(LOCAL_BLKCNT,local_blkcnt)1290 void ENTFTN(LOCAL_BLKCNT, local_blkcnt)(void *blkcnt_b, void *array_b,
1291 void *dim_b, void *proc_b,
1292 F90_Desc *blkcnt_s, F90_Desc *array_s,
1293 F90_Desc *dim_s, F90_Desc *proc_s)
1294 {
1295 DECL_HDR_PTRS(gs);
1296 DECL_DIM_PTRS(gsd);
1297 __INT_T dim, proc;
1298 __INT_T blkcnt[MAXDIMS];
1299 __INT_T cl, cn, il, iu;
1300
1301 if (F90_TAG_G(array_s) != __DESC)
1302 __fort_abort("LOCAL_BLKCNT: argument must be array");
1303 if ((gs = DIST_ACTUAL_ARG_G(array_s)) == NULL)
1304 __fort_abort("LOCAL_BLKCNT: array is not associated with global"
1305 " actual argument");
1306
1307 if (ISPRESENT(dim_b)) {
1308 dim = I8(fetch_int)(dim_b, dim_s);
1309 if (dim < 1 || dim > F90_RANK_G(gs))
1310 __fort_abort("LOCAL_BLKCNT: invalid dim");
1311 } else
1312 dim = 0;
1313
1314 if (ISPRESENT(proc_b)) {
1315 if ((proc = I8(fetch_int)(proc_b, proc_s)) < 0 || proc >= GET_DIST_TCPUS)
1316 __fort_abort("LOCAL_BLKCNT: invalid proc");
1317 if (proc != GET_DIST_LCPU)
1318 __fort_abort("LOCAL_BLKCNT: proc .ne. my_processor() unsupported");
1319 } else
1320 proc = GET_DIST_LCPU;
1321
1322 if (dim != 0) {
1323
1324 /* compute blkcnt for specified dimension */
1325
1326 blkcnt[0] = 0;
1327 if (~F90_FLAGS_G(gs) & __OFF_TEMPLATE) {
1328 I8(__fort_cycle_bounds)(gs);
1329 SET_DIM_PTRS(gsd, gs, dim - 1);
1330 for (cl = DIST_DPTR_CL_G(gsd), cn = DIST_DPTR_CN_G(gsd); --cn >= 0;
1331 cl += DIST_DPTR_CS_G(gsd))
1332 if (I8(__fort_block_bounds)(gs, dim, cl, &il, &iu) > 0)
1333 blkcnt[0]++;
1334 }
1335 I8(store_int)(blkcnt_b, blkcnt_s, blkcnt[0]);
1336 } else {
1337
1338 /* compute blkcnt for all dimensions */
1339
1340 for (dim = F90_RANK_G(gs); dim > 0; --dim)
1341 blkcnt[dim - 1] = 0;
1342 if (~F90_FLAGS_G(gs) & __OFF_TEMPLATE) {
1343 I8(__fort_cycle_bounds)(gs);
1344 for (dim = F90_RANK_G(gs); dim > 0; --dim) {
1345 SET_DIM_PTRS(gsd, gs, dim - 1);
1346 for (cl = DIST_DPTR_CL_G(gsd), cn = DIST_DPTR_CN_G(gsd); --cn >= 0;
1347 cl += DIST_DPTR_CS_G(gsd))
1348 if (I8(__fort_block_bounds)(gs, dim, cl, &il, &iu) > 0)
1349 blkcnt[dim - 1]++;
1350 }
1351 }
1352 I8(store_vector)(blkcnt_b, blkcnt_s, blkcnt, F90_RANK_G(gs));
1353 }
1354 }
1355
1356 /* Return the lower indices of all non-empty blocks. */
1357
ENTFTN(LOCAL_LINDEX,local_lindex)1358 void ENTFTN(LOCAL_LINDEX, local_lindex)(void *lindex_b, void *array_b,
1359 void *dim_b, void *proc_b,
1360 F90_Desc *lindex_s, F90_Desc *array_s,
1361 F90_Desc *dim_s, F90_Desc *proc_s)
1362 {
1363 DECL_HDR_PTRS(gs);
1364 DECL_DIM_PTRS(gsd);
1365 __INT_T dim;
1366 __INT_T proc;
1367 __INT_T blkcnt, cl, cn, il, iu;
1368
1369 /* check array argument */
1370
1371 if (F90_TAG_G(array_s) != __DESC)
1372 __fort_abort("LOCAL_LINDEX: argument must be array");
1373 if ((gs = DIST_ACTUAL_ARG_G(array_s)) == NULL)
1374 __fort_abort("LOCAL_LINDEX: array is not associated with global"
1375 " actual argument");
1376
1377 /* check dim argument */
1378
1379 dim = I8(fetch_int)(dim_b, dim_s);
1380 if (dim < 1 || dim > F90_RANK_G(gs))
1381 __fort_abort("LOCAL_LINDEX: invalid dim argument");
1382
1383 /* check proc argument */
1384
1385 if (ISPRESENT(proc_b)) {
1386 proc = I8(fetch_int)(proc_b, proc_s);
1387 if (proc < 0 || proc >= GET_DIST_TCPUS)
1388 __fort_abort("LOCAL_LINDEX: invalid proc argument");
1389 if (proc != GET_DIST_LCPU)
1390 __fort_abort("LOCAL_LINDEX: proc .ne. my_processor() unsupported");
1391 } else
1392 proc = GET_DIST_LCPU;
1393
1394 /* compute lower indices of all non-empty blocks */
1395
1396 if (~F90_FLAGS_G(gs) & __OFF_TEMPLATE) {
1397 I8(__fort_cycle_bounds)(gs);
1398 SET_DIM_PTRS(gsd, gs, dim - 1);
1399 blkcnt = 0;
1400 for (cl = DIST_DPTR_CL_G(gsd), cn = DIST_DPTR_CN_G(gsd); --cn >= 0;
1401 cl += DIST_DPTR_CS_G(gsd)) {
1402 if (I8(__fort_block_bounds)(gs, dim, cl, &il, &iu) > 0) {
1403
1404 DECL_DIM_PTRS(asd);
1405
1406 SET_DIM_PTRS(asd, array_s, dim - 1);
1407
1408 switch (DFMT(gs, dim)) {
1409 case DFMT_CYCLIC:
1410 case DFMT_CYCLIC_K: {
1411
1412 __INT_T aolb, aoub, j, lof;
1413
1414 aolb = DIST_DPTR_OLB_G(asd);
1415 aoub = DIST_DPTR_OUB_G(asd);
1416
1417 /* compute local offset for cyclic distribution */
1418
1419 j = DIST_DPTR_TSTRIDE_G(gsd) * il + DIST_DPTR_TOFFSET_G(gsd) -
1420 DIST_DPTR_CLB_G(gsd);
1421 j = Abs(j);
1422 RECIP_DIV(&j, j, DIST_DPTR_CYCLE_G(gsd));
1423 lof = j * DIST_DPTR_COFSTR_G(gsd);
1424
1425 il = F90_DPTR_SSTRIDE_G(gsd) * il + F90_DPTR_SOFFSET_G(gsd) - lof -
1426 (DIST_DPTR_OLB_G(gsd) - aolb);
1427
1428 while (il > aoub) {
1429 il -= (DIST_DPTR_CYCLE_G(gsd) - DIST_DPTR_BLOCK_G(gsd));
1430 }
1431
1432 while (il < aolb) {
1433 il += (aoub - aolb + 1);
1434 }
1435 break;
1436 }
1437
1438 default:
1439 /* block or unmapped: subtract the difference between
1440 global and local owned bounds */
1441 il -= (DIST_DPTR_OLB_G(gsd) - DIST_DPTR_OLB_G(asd));
1442 }
1443 I8(store_element)(lindex_b, lindex_s, ++blkcnt, il);
1444 }
1445 }
1446 }
1447 }
1448
1449 /* Return the upper indices of all non-empty blocks */
1450
ENTFTN(LOCAL_UINDEX,local_uindex)1451 void ENTFTN(LOCAL_UINDEX, local_uindex)(void *uindex_b, void *array_b,
1452 void *dim_b, void *proc_b,
1453 F90_Desc *uindex_s, F90_Desc *array_s,
1454 F90_Desc *dim_s, F90_Desc *proc_s)
1455 {
1456 DECL_HDR_PTRS(gs);
1457 DECL_DIM_PTRS(gsd);
1458 __INT_T dim;
1459 __INT_T proc;
1460 __INT_T blkcnt, cl, cn, il, iu;
1461
1462 /* check array argument */
1463
1464 if (F90_TAG_G(array_s) != __DESC)
1465 __fort_abort("LOCAL_UINDEX: argument must be array");
1466 if ((gs = DIST_ACTUAL_ARG_G(array_s)) == NULL)
1467 __fort_abort("LOCAL_UINDEX: array is not associated with global"
1468 " actual argument");
1469
1470 /* check dim argument */
1471
1472 dim = I8(fetch_int)(dim_b, dim_s);
1473 if (dim < 1 || dim > F90_RANK_G(gs))
1474 __fort_abort("LOCAL_UINDEX: invalid dim argument");
1475
1476 /* check proc argument */
1477
1478 if (ISPRESENT(proc_b)) {
1479 proc = I8(fetch_int)(proc_b, proc_s);
1480 if (proc < 0 || proc >= GET_DIST_TCPUS)
1481 __fort_abort("LOCAL_UINDEX: invalid proc argument");
1482 if (proc != GET_DIST_LCPU)
1483 __fort_abort("LOCAL_UINDEX: proc .ne. my_processor() unsupported");
1484 } else
1485 proc = GET_DIST_LCPU;
1486
1487 /* compute upper indices of all non-empty blocks */
1488
1489 if (~F90_FLAGS_G(gs) & __OFF_TEMPLATE) {
1490 I8(__fort_cycle_bounds)(gs);
1491 SET_DIM_PTRS(gsd, gs, dim - 1);
1492 blkcnt = 0;
1493 for (cl = DIST_DPTR_CL_G(gsd), cn = DIST_DPTR_CN_G(gsd); --cn >= 0;
1494 cl += DIST_DPTR_CS_G(gsd)) {
1495 if (I8(__fort_block_bounds)(gs, dim, cl, &il, &iu) > 0) {
1496 DECL_DIM_PTRS(asd);
1497
1498 SET_DIM_PTRS(asd, array_s, dim - 1);
1499
1500 switch (DFMT(gs, dim)) {
1501 case DFMT_CYCLIC:
1502 case DFMT_CYCLIC_K: {
1503
1504 __INT_T aolb, aoub, j, lof;
1505
1506 aolb = DIST_DPTR_OLB_G(asd);
1507 aoub = DIST_DPTR_OUB_G(asd);
1508
1509 /* compute local offset for cyclic distribution */
1510
1511 j = DIST_DPTR_TSTRIDE_G(gsd) * iu + DIST_DPTR_TOFFSET_G(gsd) -
1512 DIST_DPTR_CLB_G(gsd);
1513 j = Abs(j);
1514 RECIP_DIV(&j, j, DIST_DPTR_CYCLE_G(gsd));
1515 lof = j * DIST_DPTR_COFSTR_G(gsd);
1516
1517 iu = F90_DPTR_SSTRIDE_G(gsd) * iu + F90_DPTR_SOFFSET_G(gsd) - lof -
1518 (DIST_DPTR_OLB_G(gsd) - aolb);
1519
1520 while (iu > aoub) {
1521 iu -= (DIST_DPTR_CYCLE_G(gsd) - DIST_DPTR_BLOCK_G(gsd));
1522 }
1523
1524 while (iu < aolb) {
1525 iu += (aoub - aolb + 1);
1526 }
1527 break;
1528 }
1529
1530 default:
1531 /* block or unmapped: subtract the difference between
1532 global and local owned bounds */
1533 iu -= (DIST_DPTR_OLB_G(gsd) - DIST_DPTR_OLB_G(asd));
1534 }
1535 I8(store_element)(uindex_b, uindex_s, ++blkcnt, iu);
1536 }
1537 }
1538 }
1539 }
1540
1541 /* system inquiry routines */
1542
ENTFTN(PROCESSORS_SHAPE,processors_shape)1543 void ENTFTN(PROCESSORS_SHAPE, processors_shape)(__INT_T *shape,
1544 F90_Desc *shape_s)
1545 {
1546 I8(store_vector_int)(shape, shape_s, GET_DIST_TCPUS_ADDR, 1);
1547 }
1548
1549 #ifndef DESC_I8
1550
1551 __INT_T
ENTFTN(MY_PROCESSOR,my_processor)1552 ENTFTN(MY_PROCESSOR, my_processor)() { return GET_DIST_LCPU; }
1553
1554 __INT_T
ENTFTN(MYPROCNUM,myprocnum)1555 ENTFTN(MYPROCNUM, myprocnum)() { return GET_DIST_LCPU; }
1556
1557 int
__fort_nprocs()1558 __fort_nprocs()
1559 {
1560 return GET_DIST_TCPUS;
1561 }
1562
1563 __INT_T
ENTFTN(NPROCS,nprocs)1564 ENTFTN(NPROCS, nprocs)() { return GET_DIST_TCPUS; }
1565
1566 __INT_T
ENTFTN(NUMBER_OF_PROCESSORS,number_of_processors)1567 ENTFTN(NUMBER_OF_PROCESSORS, number_of_processors)
1568 (__INT_T *dim, __INT_T *szdim)
1569 {
1570 int d, np;
1571
1572 np = GET_DIST_TCPUS;
1573 if (ISPRESENT(dim)) {
1574 d = __fort_varying_int(dim, szdim);
1575 if (d != 1)
1576 np = 1;
1577 }
1578 return np;
1579 }
1580
1581 __INT8_T
ENTFTN(KNUMBER_OF_PROCESSORS,knumber_of_processors)1582 ENTFTN(KNUMBER_OF_PROCESSORS, knumber_of_processors)
1583 (__INT_T *dim, __INT_T *szdim)
1584 {
1585
1586 /*
1587 * -i8 variant of NUMBER_OF_PROCESSORS
1588 */
1589
1590 int d, np;
1591
1592 np = GET_DIST_TCPUS;
1593 if (ISPRESENT(dim)) {
1594 d = __fort_varying_int(dim, szdim);
1595 if (d != 1)
1596 np = 1;
1597 }
1598 return np;
1599 }
1600
1601 __INT_T
ENTFTN(PROCESSORS_RANK,processors_rank)1602 ENTFTN(PROCESSORS_RANK, processors_rank)() { return 1; }
1603
1604 __INT8_T
ENTFTN(KPROCESSORS_RANK,kprocessors_rank)1605 ENTFTN(KPROCESSORS_RANK, kprocessors_rank)()
1606 {
1607
1608 /*
1609 * -i8 variant of PROCESSORS_RANK
1610 */
1611
1612 return 1;
1613 }
1614
1615 /* Translate processor number to processor grid coordinates.
1616 rank and shape describe the processor grid. The processor
1617 number given by procnum is translated to grid coordinates returned
1618 in coord. Grid coordinates are integers between 1 and the size of
1619 the corresponding grid dimension. If the processor number is
1620 outside the bounds of the processor grid, zeroes are returned in
1621 coord. */
1622
1623 void
__fort_procnum_to_coord(int procnum,int rank,__INT_T * shape,__INT_T * coord)1624 __fort_procnum_to_coord(int procnum, int rank, __INT_T *shape, __INT_T *coord)
1625 {
1626 int i, m;
1627
1628 if (procnum >= 0) {
1629 for (i = 0; i < rank; ++i) {
1630 if (shape[i] <= 0)
1631 __fort_abort("PROCNUM_TO_COORD: invalid processor shape");
1632 m = procnum / shape[i];
1633 coord[i] = procnum - m * shape[i] + 1;
1634 procnum = m;
1635 }
1636 }
1637 if (procnum != 0) {
1638 for (i = rank; --i >= 0;)
1639 coord[i] = 0;
1640 }
1641 }
1642
ENTFTN(PROCNUM_TO_COORD,procnum_to_coord)1643 void ENTFTN(PROCNUM_TO_COORD, procnum_to_coord)(__INT_T *procnum, __INT_T *rank,
1644 __INT_T *shape, __INT_T *coord)
1645 {
1646 __fort_procnum_to_coord(*procnum, *rank, shape, coord);
1647 }
1648
1649 /* Translate processor grid coordinates to processor number.
1650 rank and shape describe the processor grid. The processor grid
1651 coordinates in coord are translated to a processor number.
1652 Grid coordinates are integers between 1 and the size of the
1653 corresponding grid dimension. If the coordinates are outside the
1654 bounds of the processor grid, -1 is returned. */
1655
1656 int
__fort_coord_to_procnum(__INT_T rank,__INT_T * shape,__INT_T * coord)1657 __fort_coord_to_procnum(__INT_T rank, __INT_T *shape, __INT_T *coord)
1658 {
1659 int i, m, p;
1660
1661 m = 1;
1662 p = 0;
1663 for (i = 0; i < rank; ++i) {
1664 if (shape[i] <= 0)
1665 __fort_abort("COORD_TO_PROCNUM: invalid processor shape");
1666 if (coord[i]<1 | coord[i]> shape[i])
1667 return -1;
1668 p += (coord[i] - 1) * m;
1669 m *= shape[i];
1670 }
1671 return p;
1672 }
1673
1674 __INT_T
ENTFTN(COORD_TO_PROCNUM,coord_to_procnum)1675 ENTFTN(COORD_TO_PROCNUM, coord_to_procnum)
1676 (__INT_T *rank, __INT_T *shape, __INT_T *coord)
1677 {
1678 return __fort_coord_to_procnum(*rank, shape, coord);
1679 }
1680
1681 #endif
1682