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 /* mget.c -- scalar broadcast routine */
21
22 #include "stdioInterf.h"
23 #include "fioMacros.h"
24
25 #define QTREE
26
27 #include "fort_vars.h"
28 extern void (*__fort_scalar_copy[__NTYPES])(void *rp, void *sp, int size);
29
30 static int _1 = 1;
31
32 static void
mget_send(chdr ** ch,int to,int me,char * rb,dtype kind,int size)33 mget_send(chdr **ch, int to, int me, char *rb, dtype kind, int size)
34 {
35 int *tcpus_addr;
36
37 tcpus_addr = GET_DIST_TCPUS_ADDR;
38 if (to == me)
39 return;
40 if (*ch == NULL)
41 *ch = __fort_chn_1to1(NULL, 1, 0, tcpus_addr, &_1, 1, 0, tcpus_addr, &_1);
42 __fort_sendl(*ch, to, rb, 1, 1, kind, size);
43 #if defined(DEBUG)
44 if (__fort_test & DEBUG_SCAL)
45 printf("%d mget_scalar send to=%d\n", me, to);
46 #endif
47 }
48
49 static void
mget_recv(chdr ** ch,int me,int from,char * rb,dtype kind,int size)50 mget_recv(chdr **ch, int me, int from, char *rb, dtype kind, int size)
51 {
52 int *tcpus_addr;
53
54 tcpus_addr = GET_DIST_TCPUS_ADDR;
55 if (from == me)
56 return;
57 if (*ch == NULL)
58 *ch = __fort_chn_1to1(NULL, 1, 0, tcpus_addr, &_1, 1, 0, tcpus_addr, &_1);
59 __fort_recvl(*ch, from, rb, 1, 1, kind, size);
60 #if defined(DEBUG)
61 if (__fort_test & DEBUG_SCAL)
62 printf("%d mget_scalar recv from=%d\n", me, from);
63 #endif
64 }
65
ENTFTN(MGET_SCALAR,mget_scalar)66 void ENTFTN(MGET_SCALAR, mget_scalar)(__INT_T *nb, ...)
67 /* ... = {void *rb, void *ab,F90_Desc *as, __INT_T *i1, ..., __INT_T *iR}* */
68 {
69 va_list va;
70 char *rb, *ab, *ap;
71 DECL_HDR_PTRS(as);
72 chdr *ch;
73 int me, np, from, partner, j, k;
74 __INT_T i, n, idx[MAXDIMS];
75
76 me = GET_DIST_LCPU;
77 np = GET_DIST_TCPUS;
78
79 ch = NULL;
80
81 va_start(va, nb);
82 for (n = *nb; n > 0; --n) {
83 rb = va_arg(va, char *);
84 ab = va_arg(va, char *);
85 as = va_arg(va, F90_Desc *);
86 #if defined(DEBUG)
87 if (rb == NULL)
88 __fort_abort("mget_scalar: invalid result address");
89 if (ab == NULL)
90 __fort_abort("mget_scalar: invalid array address");
91 if (F90_TAG_G(as) != __DESC)
92 __fort_abort("mget_scalar: invalid section descriptor");
93 #endif
94 for (i = 0; i < F90_RANK_G(as); ++i)
95 idx[i] = *va_arg(va, __INT_T *);
96
97 /* shortcut for replicated arrays */
98
99 if (DIST_MAPPED_G(DIST_ALIGN_TARGET_G(as)) == 0)
100 {
101 ap = I8(__fort_local_address)(ab, as, idx);
102 if (ap == NULL)
103 __fort_abort("mget_scalar: localization error");
104 __fort_scalar_copy[F90_KIND_G(as)](rb, ap, F90_LEN_G(as));
105 continue;
106 }
107
108 from = I8(__fort_owner)(as, idx);
109
110 if (from == me) {
111 ap = I8(__fort_local_address)(ab, as, idx);
112 #if defined(DEBUG)
113 if (ap == NULL)
114 __fort_abort("mget_scalar: localization error");
115
116 if (__fort_test & DEBUG_SCAL) {
117 printf("%d mget_scalar bcst a", me);
118 I8(__fort_show_index)(F90_RANK_G(as), idx);
119 printf("@%x =", ap);
120 __fort_show_scalar(ap, F90_KIND_G(as));
121 printf("\n");
122 }
123 #endif
124 __fort_scalar_copy[F90_KIND_G(as)](rb, ap, F90_LEN_G(as));
125 }
126
127 if (from == me) {
128 for (partner = 0; partner < np; ++partner)
129 mget_send(&ch, partner, me, rb, F90_KIND_G(as), F90_LEN_G(as));
130 } else
131 mget_recv(&ch, me, from, rb, F90_KIND_G(as), F90_LEN_G(as));
132 }
133 va_end(va);
134
135 if (ch) {
136 __fort_chn_prune(ch);
137 __fort_doit(ch);
138 __fort_frechn(ch);
139 }
140 }
141