1 /*
2 * Copyright (c) 1997-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 /* utility functions */
19
20 #include <stdioInterf.h>
21 #include "fioMacros.h"
22
23 /* given address and size, fetch scalar integer and convert to C int */
24
I8(__fort_varying_int)25 int I8(__fort_varying_int)(void *b, __INT_T *size)
26 {
27 switch (*size) {
28 case 1:
29 return (int)(*(__INT1_T *)b);
30 case 2:
31 return (int)(*(__INT2_T *)b);
32 case 4:
33 return (int)(*(__INT4_T *)b);
34 case 8:
35 return (int)(*(__INT8_T *)b);
36 default:
37 __fort_abort("varying_int: incorrect size");
38 return 0;
39 }
40 }
41
42 /* given address and size, fetch scalar logical and convert to C int */
43
I8(__fort_varying_log)44 int I8(__fort_varying_log)(void *b, __INT_T *size)
45 {
46 switch (*size) {
47 case 1:
48 return (*(__LOG1_T *)b & GET_DIST_MASK_LOG1) != 0;
49 case 2:
50 return (*(__LOG2_T *)b & GET_DIST_MASK_LOG2) != 0;
51 case 4:
52 return (*(__LOG4_T *)b & GET_DIST_MASK_LOG4) != 0;
53 case 8:
54 return (*(__LOG8_T *)b & GET_DIST_MASK_LOG8) != 0;
55 default:
56 __fort_abort("varying_log: incorrect size");
57 return 0;
58 }
59 }
60
61 /* given address and descriptor, fetch scalar integer and convert to C
62 int */
63
I8(__fort_fetch_int)64 int I8(__fort_fetch_int)(void *b, F90_Desc *d)
65 {
66 dtype kind;
67
68 if (F90_TAG_G(d) == __DESC) {
69 if (F90_RANK_G(d) != 0)
70 __fort_abort("fetch_int: non-scalar destination");
71 if (F90_FLAGS_G(d) & __OFF_TEMPLATE)
72 __fort_abort("fetch_int: non-local value");
73 b += DIST_SCOFF_G(d) * F90_LEN_G(d);
74 kind = F90_KIND_G(d);
75 } else
76 kind = Abs(F90_TAG_G(d));
77
78 switch (kind) {
79 case __INT1:
80 return (int)(*(__INT1_T *)b);
81 case __INT2:
82 return (int)(*(__INT2_T *)b);
83 case __INT4:
84 return (int)(*(__INT4_T *)b);
85 case __INT8:
86 return (int)(*(__INT8_T *)b);
87 default:
88 __fort_abort("fetch_int: non-integer type");
89 return 0;
90 }
91 }
92
93 /* store scalar integer */
94
I8(__fort_store_int)95 void I8(__fort_store_int)(void *b, F90_Desc *d, int val)
96 {
97 dtype kind;
98
99 if (F90_TAG_G(d) == __DESC) {
100 if (F90_RANK_G(d) != 0)
101 __fort_abort("store_int: non-scalar destination");
102 if (F90_FLAGS_G(d) & __OFF_TEMPLATE)
103 return;
104 b += DIST_SCOFF_G(d) * F90_LEN_G(d);
105 kind = F90_KIND_G(d);
106 } else
107 kind = Abs(F90_TAG_G(d));
108
109 switch (kind) {
110 case __INT1:
111 *(__INT1_T *)b = (__INT1_T)val;
112 break;
113 case __INT2:
114 *(__INT2_T *)b = (__INT2_T)val;
115 break;
116 case __INT4:
117 *(__INT4_T *)b = (__INT4_T)val;
118 break;
119 case __INT8:
120 *(__INT8_T *)b = (__INT8_T)val;
121 break;
122 default:
123 __fort_abort("store_int: non-integer type");
124 }
125 }
126
127 /* given address and descriptor, fetch scalar fortran logical and
128 convert to C int */
129
I8(__fort_fetch_log)130 int I8(__fort_fetch_log)(void *b, F90_Desc *d)
131 {
132 dtype kind;
133
134 if (F90_TAG_G(d) == __DESC) {
135 if (F90_RANK_G(d) != 0)
136 __fort_abort("fetch_log: non-scalar destination");
137 if (F90_FLAGS_G(d) & __OFF_TEMPLATE)
138 __fort_abort("fetch_int: non-local value");
139 b += DIST_SCOFF_G(d) * F90_LEN_G(d);
140 kind = F90_KIND_G(d);
141 } else
142 kind = Abs(F90_TAG_G(d));
143
144 switch (kind) {
145 case __LOG1:
146 return (*(__LOG1_T *)b & GET_DIST_MASK_LOG1) != 0;
147 case __LOG2:
148 return (*(__LOG2_T *)b & GET_DIST_MASK_LOG2) != 0;
149 case __LOG4:
150 return (*(__LOG4_T *)b & GET_DIST_MASK_LOG4) != 0;
151 case __LOG8:
152 return (*(__LOG8_T *)b & GET_DIST_MASK_LOG8) != 0;
153 default:
154 __fort_abort("fetch_log: non-logical type");
155 return 0;
156 }
157 }
158
159 /* convert C int and store scalar fortran logical */
160
I8(__fort_store_log)161 void I8(__fort_store_log)(void *b, F90_Desc *d, int val)
162 {
163 dtype kind;
164
165 if (F90_TAG_G(d) == __DESC) {
166 if (F90_RANK_G(d) != 0)
167 __fort_abort("store_log: non-scalar destination");
168 if (F90_FLAGS_G(d) & __OFF_TEMPLATE)
169 return;
170 b += DIST_SCOFF_G(d) * F90_LEN_G(d);
171 kind = F90_KIND_G(d);
172 } else
173 kind = Abs(F90_TAG_G(d));
174
175 switch (kind) {
176 case __LOG1:
177 *(__LOG1_T *)b = val ? GET_DIST_TRUE_LOG1 : 0;
178 break;
179 case __LOG2:
180 *(__LOG2_T *)b = val ? GET_DIST_TRUE_LOG2 : 0;
181 break;
182 case __LOG4:
183 *(__LOG4_T *)b = val ? GET_DIST_TRUE_LOG4 : 0;
184 break;
185 case __LOG8:
186 *(__LOG8_T *)b = val ? GET_DIST_TRUE_LOG8 : 0;
187 break;
188 default:
189 __fort_abort("store_log: non-logical type");
190 }
191 }
192
193 /* fetch the i'th element of an integer vector */
194
I8(__fort_fetch_int_element)195 int I8(__fort_fetch_int_element)(void *b, F90_Desc *d, int i)
196 {
197 double tmp[2];
198 __INT_T idx;
199 int val;
200
201 if (F90_RANK_G(d) != 1)
202 __fort_abort("fetch_int_element: non-unit rank");
203
204 idx = F90_DIM_LBOUND_G(d, 0) - 1 + i;
205 I8(__fort_get_scalar)(tmp, b, d, &idx);
206 switch (F90_KIND_G(d)) {
207 case __INT1:
208 val = (int)(*(__INT1_T *)tmp);
209 break;
210 case __INT2:
211 val = (int)(*(__INT2_T *)tmp);
212 break;
213 case __INT4:
214 val = (int)(*(__INT4_T *)tmp);
215 break;
216 case __INT8:
217 val = (int)(*(__INT8_T *)tmp);
218 break;
219 default:
220 __fort_abort("fetch_int_element: non-integer type");
221 }
222 return val;
223 }
224
225 /* store the i'th element of an integer vector */
226
I8(__fort_store_int_element)227 void I8(__fort_store_int_element)(void *b, F90_Desc *d, int i, int val)
228 {
229 void *adr;
230 __INT_T idx;
231
232 if (F90_RANK_G(d) != 1)
233 __fort_abort("store_int_element: non-unit rank");
234
235 idx = F90_DIM_LBOUND_G(d, 0) - 1 + i;
236 adr = I8(__fort_local_address)(b, d, &idx);
237 if (adr != NULL) {
238 switch (F90_KIND_G(d)) {
239 case __INT1:
240 *(__INT1_T *)adr = (__INT1_T)val;
241 break;
242 case __INT2:
243 *(__INT2_T *)adr = (__INT2_T)val;
244 break;
245 case __INT4:
246 *(__INT4_T *)adr = (__INT4_T)val;
247 break;
248 case __INT8:
249 *(__INT8_T *)adr = (__INT8_T)val;
250 break;
251 default:
252 __fort_abort("store_int_element: non-integer type");
253 }
254 }
255 }
256
257 /* fetch integer vector */
258
I8(__fort_fetch_int_vector)259 void I8(__fort_fetch_int_vector)(void *b, F90_Desc *d, int *vec, int veclen)
260 {
261 double tmp[2];
262 dtype kind;
263 __INT_T i;
264
265 if (F90_RANK_G(d) != 1)
266 __fort_abort("fetch_vector: non-unit rank");
267
268 for (i = F90_DIM_LBOUND_G(d, 0); --veclen >= 0; ++i, ++vec) {
269 I8(__fort_get_scalar)(tmp, b, d, &i);
270 switch (F90_KIND_G(d)) {
271 case __INT1:
272 *vec = (int)(*(__INT1_T *)tmp);
273 break;
274 case __INT2:
275 *vec = (int)(*(__INT2_T *)tmp);
276 break;
277 case __INT4:
278 *vec = (int)(*(__INT4_T *)tmp);
279 break;
280 case __INT8:
281 *vec = (int)(*(__INT8_T *)tmp);
282 break;
283 default:
284 __fort_abort("fetch_int_vector: non-integer type");
285 }
286 }
287 }
288
289 /* store integer vector */
290
I8(__fort_store_int_vector)291 void I8(__fort_store_int_vector)(void *b, F90_Desc *d, int *vec, int veclen)
292 {
293 void *adr;
294 __INT_T i;
295
296 if (F90_RANK_G(d) != 1)
297 __fort_abort("store_int_vector: non-unit rank");
298
299 for (i = F90_DIM_LBOUND_G(d, 0); --veclen >= 0; ++i, ++vec) {
300 adr = I8(__fort_local_address)(b, d, &i);
301 if (adr != NULL) {
302 switch (F90_KIND_G(d)) {
303 case __INT1:
304 *(__INT1_T *)adr = (__INT1_T)*vec;
305 break;
306 case __INT2:
307 *(__INT2_T *)adr = (__INT2_T)*vec;
308 break;
309 case __INT4:
310 *(__INT4_T *)adr = (__INT4_T)*vec;
311 break;
312 case __INT8:
313 *(__INT8_T *)adr = (__INT8_T)*vec;
314 break;
315 default:
316 __fort_abort("store_int_vector: non-integer type");
317 }
318 }
319 }
320 }
321
322 #ifndef DESC_I8
323
324 /* fortran string copy */
__fort_ftnstrcpy(char * dst,int len,char * src)325 void __fort_ftnstrcpy(char *dst, /* destination string, blank-filled */
326 int len, /* length of destination space */
327 char *src) /* null terminated source string */
328 {
329 char *end = dst + len;
330 while (dst < end && *src != '\0')
331 *dst++ = *src++;
332 while (dst < end)
333 *dst++ = ' ';
334 }
335
336 #endif
337