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 /** \file
21 * \brief Support for namelist write statements.
22 */
23
24 #include <ctype.h>
25 #include <string.h>
26 #include "global.h"
27 #include "format.h"
28 #include "nml.h"
29
30 /*** define a few things for run-time tracing ***/
31 static int dbgflag;
32 #undef DBGBIT
33 #define DBGBIT(v) (LOCAL_DEBUG && (dbgflag & v))
34
35 static FIO_FCB *f;
36
37 static char *in_recp; /* internal i/o record (user's space) */
38 static char *in_curp; /* current position in internal i/o record */
39
40 static int byte_cnt;
41 static int rec_len;
42 static int n_irecs; /* number of records in internal file */
43 static bool internal_file; /* TRUE if writing to internal file */
44 static char *internal_unit; /* base address of internal file buffer */
45 static char delim;
46 static bool need_comma;
47 static int skip;
48
49 typedef struct {
50 short decimal; /* COMMA, POINT, NONE */
51 short sign; /* FIO_ PLUS, SUPPRESS, PROCESSOR_DEFINED,
52 * NONE
53 */
54 short round; /* FIO_ UP, DOWN, etc. */
55
56 FIO_FCB *f;
57
58 char *in_recp; /* internal i/o record (user's space) */
59 char *in_curp; /* current position in internal i/o record */
60
61 int byte_cnt;
62 int rec_len;
63 int n_irecs; /* number of records in internal file */
64 bool internal_file; /* TRUE if writing to internal file */
65 char *internal_unit; /* base address of internal file buffer */
66 char delim;
67 bool need_comma;
68 int skip;
69 int same_fcb_idx;
70
71 __INT_T *unit; /* used in user defined io */
72 __INT_T *iostat; /* used in user defined io */
73 } G;
74
75 static G static_gbl[GBL_SIZE];
76 static G *gbl = &static_gbl[0];
77 static G *gbl_head = &static_gbl[0];
78 static int gbl_avl = 0;
79 static int gbl_size = GBL_SIZE;
80
81 static int emit_eol(void);
82 static int write_nml_val(NML_DESC **, NML_DESC *, char *);
83 static int write_item(char *, int);
84 static int write_char(int);
85 static int eval(int, char *, NML_DESC *, NML_DESC **);
86 static int eval_dtio(int, char *, NML_DESC *, NML_DESC **);
87 static int I8(eval_sb)(NML_DESC **, NML_DESC *, char *, int);
88 static int I8(eval_dtio_sb)(NML_DESC **, NML_DESC *, char *, int);
89 static int dtio_write_scalar(NML_DESC **, NML_DESC *, char *, int);
90
91 static SB sb;
92 static TRI tri;
93
94 /* ---------------------------------------------------------------- */
95
96 static int
_f90io_nmlw_init(__INT_T * unit,__INT_T * rec,__INT_T * bitv,__INT_T * iostat)97 _f90io_nmlw_init(__INT_T *unit, /* unit number */
98 __INT_T *rec, /* record number for direct access I/O;
99 * rec not used, but JUST IN CASE
100 */
101 __INT_T *bitv, /* same as for ENTF90IO(open_) */
102 __INT_T *iostat) /* same as for ENTF90IO(open_) */
103 {
104 __fortio_errinit03(*unit, *bitv, iostat, "namelist write");
105
106 f = __fortio_rwinit(*unit, FIO_FORMATTED, rec, 1 /*write*/);
107 if (f == NULL)
108 return ERR_FLAG;
109 f->skip = 0;
110
111 if (f->delim == FIO_APOSTROPHE) {
112 delim = '\'';
113 } else if (f->delim == FIO_QUOTE) {
114 delim = '\"';
115 } else {
116 delim = 0;
117 }
118 gbl->decimal = f->decimal;
119 gbl->sign = f->sign;
120 gbl->round = f->round;
121 gbl->unit = unit;
122 gbl->iostat = iostat;
123
124 return 0;
125 }
126
127 /** \brief Initialize for namelist write to an external file
128 *
129 * \param unit - unit number
130 * \param rec - record number for direct access I/O; rec not used, but JUST IN CASE
131 * \param bitv - same as for ENTF90IO(open_)
132 * \param iostat - same as for ENTF90IO(open_)
133 */
134 int
ENTF90IO(NMLW_INIT,nmlw_init)135 ENTF90IO(NMLW_INIT, nmlw_init)(__INT_T *unit,
136 __INT_T *rec,
137 __INT_T *bitv,
138 __INT_T *iostat)
139 {
140 int s = 0;
141
142 internal_file = FALSE;
143 __fort_status_init(bitv, iostat);
144 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC)
145 s = _f90io_nmlw_init(unit, rec, bitv, iostat);
146 return DIST_STATUS_BCST(s);
147 }
148
149 int
ENTF90IO(NMLW_INIT03A,nmlw_init03a)150 ENTF90IO(NMLW_INIT03A, nmlw_init03a)(__INT_T *istat,
151 DCHAR(decimal),
152 DCHAR(delim),
153 DCHAR(sign)
154 DCLEN64(decimal)
155 DCLEN64(delim)
156 DCLEN64(sign))
157 {
158 int s = *istat;
159
160 if (s)
161 return DIST_STATUS_BCST(s);
162
163 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC) {
164 if (ISPRESENTC(decimal)) {
165 if (__fortio_eq_str(CADR(decimal), CLEN(decimal), "COMMA")) {
166 gbl->decimal = FIO_COMMA;
167 } else if (__fortio_eq_str(CADR(decimal), CLEN(decimal), "POINT")) {
168 gbl->decimal = FIO_POINT;
169 } else
170 s = __fortio_error(FIO_ESPEC);
171 }
172 if (ISPRESENTC(delim)) {
173 if (__fortio_eq_str(CADR(delim), CLEN(delim), "APOSTROPHE"))
174 delim = '\'';
175 else if (__fortio_eq_str(CADR(delim), CLEN(delim), "QUOTE"))
176 delim = '\"';
177 else if (__fortio_eq_str(CADR(delim), CLEN(delim), "NONE"))
178 delim = 0;
179 else
180 return __fortio_error(FIO_ESPEC);
181 }
182 if (ISPRESENTC(sign)) {
183 if (__fortio_eq_str(CADR(sign), CLEN(sign), "PLUS")) {
184 gbl->sign = FIO_PLUS;
185 } else if (__fortio_eq_str(CADR(sign), CLEN(sign), "SUPPRESS")) {
186 gbl->sign = FIO_SUPPRESS;
187 } else if (__fortio_eq_str(CADR(sign), CLEN(sign), "PROCESSOR_DEFINED")) {
188 gbl->sign = FIO_PROCESSOR_DEFINED;
189 } else
190 s = __fortio_error(FIO_ESPEC);
191 }
192 }
193 return DIST_STATUS_BCST(s);
194 }
195 /* 32 bit CLEN version */
196 int
ENTF90IO(NMLW_INIT03,nmlw_init03)197 ENTF90IO(NMLW_INIT03, nmlw_init03)(__INT_T *istat,
198 DCHAR(decimal),
199 DCHAR(delim),
200 DCHAR(sign)
201 DCLEN(decimal)
202 DCLEN(delim)
203 DCLEN(sign))
204 {
205 return ENTF90IO(NMLW_INIT03A, nmlw_init03a)(istat, CADR(decimal), CADR(delim),
206 CADR(sign), (__CLEN_T)CLEN(decimal),
207 (__CLEN_T)CLEN(delim), (__CLEN_T)CLEN(sign));
208 }
209
210 int
ENTCRF90IO(NMLW_INIT,nmlw_init)211 ENTCRF90IO(NMLW_INIT, nmlw_init)(__INT_T *unit, /* unit number */
212 __INT_T *rec, /* record number for direct
213 * access I/O; * rec not used,
214 * but JUST IN CASE
215 */
216 __INT_T *bitv, /*same as for ENTF90IO(open_) */
217 __INT_T *iostat) /*same as for ENTF90IO(open_) */
218 {
219 return _f90io_nmlw_init(unit, rec, bitv, iostat);
220 }
221
222 static int
_f90io_nmlw_intern_init(char * cunit,__INT_T * rec_num,__INT_T * bitv,__INT_T * iostat,__CLEN_T cunit_len)223 _f90io_nmlw_intern_init(char *cunit, /* pointer to variable or array to
224 * write into */
225 __INT_T *rec_num, /* number of records in internal file.
226 * 0 if the file is an assumed size
227 * character * array */
228 __INT_T *bitv, /* same as for ENTF90IO(open_) */
229 __INT_T *iostat, /* same as for ENTF90IO(open_) */
230 __CLEN_T cunit_len)
231 {
232 static FIO_FCB dumfcb;
233
234 __fortio_errinit03(-99, *bitv, iostat, "internal namelist write");
235 rec_len = cunit_len;
236 byte_cnt = 0;
237 in_curp = in_recp = cunit;
238 n_irecs = *rec_num;
239 delim = 0;
240
241 f = &dumfcb; /* so the f-> refs don't have to be guarded */
242
243 return 0;
244 }
245
246 /** \brief Internal file namelist write initialization
247 *
248 * \param rec_num - number of records in internal file; 0 if the file is an assumed size character array
249 * \param bitv - same as for ENTF90IO(open_)
250 * \param iostat - same as for ENTF90IO(open_)
251 */
252 int
ENTF90IO(NMLW_INTERN_INITA,nmlw_intern_inita)253 ENTF90IO(NMLW_INTERN_INITA, nmlw_intern_inita)(
254 DCHAR(cunit), /* pointer to variable or array to
255 * write into */
256 __INT_T *rec_num, /* number of records in internal file.
257 * 0 if the file is an assumed size
258 * character * array */
259 __INT_T *bitv, /* same as for ENTF90IO(open_) */
260 __INT_T *iostat /* same as for ENTF90IO(open_) */
261 DCLEN64(cunit))
262 {
263 int s = 0;
264
265 internal_file = TRUE;
266 internal_unit = CADR(cunit);
267 __fort_status_init(bitv, iostat);
268 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC)
269 s = _f90io_nmlw_intern_init(CADR(cunit), rec_num, bitv, iostat, CLEN(cunit));
270 return DIST_STATUS_BCST(s);
271 }
272 /* 32 bit CLEN version */
273 int
ENTF90IO(NMLW_INTERN_INIT,nmlw_intern_init)274 ENTF90IO(NMLW_INTERN_INIT, nmlw_intern_init)(
275 DCHAR(cunit), /* pointer to variable or array to
276 * write into */
277 __INT_T *rec_num, /* number of records in internal file.
278 * 0 if the file is an assumed size
279 * character * array */
280 __INT_T *bitv, /* same as for ENTF90IO(open_) */
281 __INT_T *iostat /* same as for ENTF90IO(open_) */
282 DCLEN(cunit))
283 {
284 return ENTF90IO(NMLW_INTERN_INITA, nmlw_intern_inita)(CADR(cunit), rec_num,
285 bitv, iostat, (__CLEN_T)CLEN(cunit));
286 }
287
288 int
ENTCRF90IO(NMLW_INTERN_INITA,nmlw_intern_inita)289 ENTCRF90IO(NMLW_INTERN_INITA, nmlw_intern_inita)(
290 DCHAR(cunit), /* pointer to variable or array to
291 * write into */
292 __INT_T *rec_num, /* number of records in internal file.
293 * 0 if the file is an assumed size
294 * character * array */
295 __INT_T *bitv, /* same as for ENTF90IO(open_) */
296 __INT_T *iostat /* same as for ENTF90IO(open_) */
297 DCLEN64(cunit))
298 {
299 internal_file = TRUE;
300 internal_unit = CADR(cunit);
301 return _f90io_nmlw_intern_init(CADR(cunit), rec_num, bitv, iostat,
302 CLEN(cunit));
303 }
304 /* 32 bit CLEN version */
305 int
ENTCRF90IO(NMLW_INTERN_INIT,nmlw_intern_init)306 ENTCRF90IO(NMLW_INTERN_INIT, nmlw_intern_init)(
307 DCHAR(cunit), /* pointer to variable or array to
308 * write into */
309 __INT_T *rec_num, /* number of records in internal file.
310 * 0 if the file is an assumed size
311 * character * array */
312 __INT_T *bitv, /* same as for ENTF90IO(open_) */
313 __INT_T *iostat /* same as for ENTF90IO(open_) */
314 DCLEN(cunit))
315 {
316 return ENTCRF90IO(NMLW_INTERN_INITA, nmlw_intern_inita)(CADR(cunit), rec_num,
317 bitv, iostat, (__CLEN_T)CLEN(cunit));
318 }
319
320 static int
emit_eol(void)321 emit_eol(void)
322 {
323 int ret_err;
324
325 if (!internal_file) {
326 #if defined(WINNT)
327 if (__fortio_binary_mode(f->fp)) {
328 ret_err = write_char('\r');
329 if (ret_err)
330 return ret_err;
331 }
332 #endif
333 return write_char('\n');
334 }
335 n_irecs--;
336 if (n_irecs < 0) /* write after last internal record */
337 return FIO_ETOOFAR;
338 /*
339 * blankfill the internal file record
340 */
341 if (rec_len > byte_cnt)
342 memset(in_curp, ' ', rec_len - byte_cnt);
343 in_recp += rec_len; /* update internal file pointer */
344 in_curp = in_recp;
345 byte_cnt = 0;
346 return 0;
347 }
348
349 static void
I8(fillup_sb)350 I8(fillup_sb)(int v, NML_DESC *descp, char *loc_addr)
351 {
352 int i, k;
353 F90_Desc *sd = get_descriptor(descp);
354 DECL_DIM_PTRS(acd);
355
356 sb.v = v;
357 sb.ndims = *(__POINT_T *)((char *)descp + sizeof(NML_DESC));
358 sb.elemsz = I8(siz_of)(descp);
359 for (i = 0; i < sb.ndims; ++i) {
360 SET_DIM_PTRS(acd, sd, i);
361 sb.idx[i] = F90_DPTR_LBOUND_G(acd);
362 sb.sect[i].lwb = F90_DPTR_LBOUND_G(acd);
363 sb.sect[i].upb = F90_DPTR_EXTENT_G(acd);
364 sb.sect[i].stride = F90_DPTR_SSTRIDE_G(acd);
365 sb.mult[i] = F90_DPTR_LSTRIDE_G(acd);
366 sb.lwb[i] = F90_DPTR_LBOUND_G(acd);
367 }
368 sb.loc_addr = loc_addr;
369 }
370
371 static int
write_nml_val(NML_DESC ** NextDescp,NML_DESC * descp,char * loc_addr)372 write_nml_val(NML_DESC **NextDescp, NML_DESC *descp, char *loc_addr)
373 {
374 int num_consts;
375 __POINT_T *desc_dims, new_ndims;
376 __POINT_T actual_ndims;
377 int i, j, k;
378 char *p;
379 int len;
380 int ret_err;
381 NML_DESC *next_descp;
382
383 num_consts = 1;
384 desc_dims = (__POINT_T *)((char *)descp + sizeof(NML_DESC));
385 if (descp->ndims == -1 || descp->ndims == -2) {
386 new_ndims = *(__POINT_T *)((char *)descp + sizeof(__POINT_T));
387 num_consts = nelems_of(descp);
388 } else {
389 num_consts = nelems_of(descp);
390 }
391
392 /* compute number of bytes to add to reach next descriptor: */
393 if (descp->ndims == -1 || descp->ndims == -2)
394 k = sizeof(NML_DESC) + (sizeof(__POINT_T) * 2);
395 else {
396 ACTUAL_NDIMS(actual_ndims);
397 k = sizeof(NML_DESC) + (actual_ndims * sizeof(__POINT_T) * 2);
398 }
399 next_descp = (NML_DESC *)((char *)descp + k);
400
401 /* print each constant for this derived type: */
402
403 if (descp->type == __DERIVED) {
404 NML_DESC *start_descp;
405 char *start_addr;
406 char *mem_addr;
407
408 start_descp = next_descp;
409 start_addr = loc_addr;
410 for (k = 0; k < num_consts; k++) {
411 next_descp = start_descp;
412 while (TRUE) {
413 if (next_descp->nlen == 0) { /* end of members */
414 next_descp = (NML_DESC *)((char *)next_descp + sizeof(__POINT_T));
415 break;
416 }
417 mem_addr = start_addr + (long)next_descp->addr;
418
419 ret_err = write_nml_val(&next_descp, next_descp, mem_addr);
420 if (ret_err)
421 return ret_err;
422 }
423 start_addr += descp->len;
424 }
425 *NextDescp = next_descp;
426 return 0;
427 }
428
429 /* print each constant for this variable/array: */
430
431 for (k = 0; k < num_consts; k++) {
432 if (need_comma) { /* put out leading blanks: */
433 /* put commas after each constant except for very, very last: */
434 if (gbl->decimal == FIO_COMMA) {
435 ret_err = write_char(';');
436 } else {
437 ret_err = write_char(',');
438 }
439 if (ret_err)
440 return __fortio_error(ret_err);
441 ret_err = emit_eol();
442 if (ret_err)
443 return __fortio_error(ret_err);
444 f->nextrec++;
445 for (j = 0; j < skip; j++) {
446 ret_err = write_char(' ');
447 if (ret_err)
448 return __fortio_error(ret_err);
449 }
450 }
451 if (descp->len > 0) { /* CHARACTER variable */
452 int c;
453
454 if (descp->type == __STR) {
455 if (delim) {
456 ret_err = write_char(delim);
457 if (ret_err)
458 return __fortio_error(ret_err);
459 }
460 for (j = 0; j < descp->len; j++) {
461 c = *loc_addr++;
462 ret_err = write_char(c);
463 if (ret_err)
464 return __fortio_error(ret_err);
465 if (delim && c == delim) {
466 ret_err = write_char(c); /* double delimiter character */
467 if (ret_err)
468 return __fortio_error(ret_err);
469 }
470 }
471 if (delim) {
472 ret_err = write_char(delim);
473 if (ret_err)
474 return __fortio_error(ret_err);
475 }
476 }
477 } else {
478 bool plus_sign;
479 if (gbl->sign == FIO_PLUS)
480 plus_sign = TRUE;
481 else
482 plus_sign = FALSE;
483 if (gbl->decimal == FIO_COMMA)
484 p = __fortio_default_convert(loc_addr, descp->type, 0, &len, TRUE,
485 plus_sign, gbl->round);
486 else
487 p = __fortio_default_convert(loc_addr, descp->type, 0, &len, FALSE,
488 plus_sign, gbl->round);
489 ret_err = write_item(p, len);
490 if (ret_err)
491 return __fortio_error(ret_err);
492
493 loc_addr += FIO_TYPE_SIZE(descp->type);
494 }
495 need_comma = TRUE;
496 }
497
498 *NextDescp = next_descp;
499 return 0;
500 }
501
502 static int
write_item(char * p,int len)503 write_item(char *p, int len)
504 {
505 int newlen;
506
507 if (DBGBIT(0x1))
508 __io_printf("write_item #%s#, len %d\n", p, len);
509
510 if (!internal_file) {
511 if (len && FWRITE(p, len, 1, f->fp) != 1)
512 return __io_errno();
513 return 0;
514 }
515 /** for internal i/o in_recp/in_curp is a pointer to user's space **/
516 newlen = byte_cnt + len;
517 if (newlen > rec_len) {
518 /*
519 * f2003 10.10.2 L9: The processor may begin new records as necessary.
520 * However, except for complex constants and character values, the end
521 * of a record shall not occur within a constant, character value, or
522 * name, and blanks shall not appear within a constant, character value,
523 * or name.
524 */
525 if (byte_cnt == 0 || len > rec_len)
526 return FIO_ETOOBIG;
527 n_irecs--;
528 if (n_irecs <= 0) /* write after last internal record */
529 return FIO_ETOOFAR;
530 /*
531 * blankfill the internal file record
532 */
533 if (rec_len > byte_cnt)
534 memset(in_curp, ' ', rec_len - byte_cnt);
535 in_recp += rec_len;
536 newlen = len;
537 in_curp = in_recp;
538 }
539 (void) memcpy(in_curp, p, len);
540 in_curp += len;
541 byte_cnt = newlen;
542 return 0;
543 }
544
545 static int
write_char(int ch)546 write_char(int ch)
547 {
548 char bf[1];
549 bf[0] = ch;
550 return write_item(bf, 1);
551 }
552
553 /** \brief
554 * Recursively compute the index space given a set of subscripts for n
555 * dimensions. The evaluation begins by iterating over the last dimension,
556 * recursively evaluating the subscripts of the next (to the left) for
557 * each iteration. For a given dimension d's index, subscripts to the left
558 * are recursively computed. When the first dimension is reached, the address
559 * of the element represented by the current subscript values is passed to
560 * the 'eval' function.
561 */
562 static int
I8(eval_sb)563 I8(eval_sb)(NML_DESC **NextDescp, NML_DESC *descp, char *loc_addr, int d)
564 {
565 int j, err, k;
566 __BIGINT_T offset, baseoffset;
567 char *new_addr;
568 NML_DESC *next_descp;
569 __POINT_T *desc_dims;
570 __POINT_T actual_ndims;
571
572 /* compute number of bytes to add to reach next descriptor: */
573 if (descp->ndims == -1 || descp->ndims == -2)
574 k = sizeof(NML_DESC) + (sizeof(__POINT_T) * 2);
575 else {
576 ACTUAL_NDIMS(actual_ndims);
577 k = sizeof(NML_DESC) + (actual_ndims * sizeof(__POINT_T) * 2);
578 }
579
580 next_descp = (NML_DESC *)((char *)descp + k);
581
582 if (descp->ndims == -1 || descp->ndims == -2) {
583 desc_dims = (__POINT_T *)((char *)descp + sizeof(NML_DESC));
584 if (*desc_dims == 0) {
585 /* $p contains an address of array/scalar */
586 new_addr = *(char **)sb.loc_addr;
587 err = write_nml_val(&next_descp, descp, new_addr);
588 if (err)
589 return err;
590 *NextDescp = next_descp;
591 return 0;
592 }
593 }
594
595 if (d == 0) {
596 /*
597 * Reached the first dimension; iterate over the first dimension,
598 * compute the address of each element, and pass each address to
599 * 'eval'.
600 */
601 F90_Desc *sd = get_descriptor(descp);
602 for (sb.idx[0] = sb.sect[0].lwb; sb.idx[0] <= sb.sect[0].upb;
603 sb.idx[0] += sb.sect[0].stride) {
604 new_addr = I8(__fort_local_address)((*(char **)sb.loc_addr), sd,
605 (__INT_T *)&sb.idx[0]);
606 err = write_nml_val(&next_descp, descp, new_addr);
607 if (err)
608 return err;
609 }
610 *NextDescp = next_descp;
611 return 0;
612 }
613
614 /* Iterate over the current dimension, and recursively evaluate all
615 * subscripts in the dimensions to the left.
616 */
617 for (sb.idx[d] = sb.sect[d].lwb; sb.idx[d] <= sb.sect[d].upb;
618 sb.idx[d] += sb.sect[d].stride) {
619 err = I8(eval_sb)(&next_descp, descp, new_addr, d - 1);
620 if (err)
621 return err;
622 }
623 *NextDescp = next_descp;
624 return 0;
625 }
626
627 /** \brief
628 * Recursively compute the index space given a set of subscripts for n
629 * dimensions. The evaluation begins by iterating over the last dimension,
630 * recursively evaluating the subscripts of the next (to the left) for
631 * each iteration. For a given dimension d's index, subscripts to the left
632 * are recursively computed. When the first dimension is reached, the address
633 * of the element represented by the current subscript values is passed to
634 * the 'eval' function.
635 */
636 static int
I8(eval_dtio_sb)637 I8(eval_dtio_sb)(NML_DESC **NextDescp, NML_DESC *descp, char *loc_addr, int d)
638 {
639 int j, err, k;
640 __BIGINT_T offset, baseoffset;
641 char *new_addr;
642 NML_DESC *next_descp;
643 __POINT_T *desc_dims;
644 __POINT_T actual_ndims;
645
646 /* compute number of bytes to add to reach next descriptor: */
647 if (descp->ndims == -2)
648 k = sizeof(NML_DESC) + (sizeof(__POINT_T) * 2);
649 else if (descp->ndims >= MAX_DIM) {
650 ACTUAL_NDIMS(actual_ndims);
651 k = sizeof(NML_DESC) + (actual_ndims * sizeof(__POINT_T) * 2);
652 } else {
653 #if DEBUG
654 printf("Error: eval_dtio_sb \n");
655 return ERR_FLAG;
656 #endif
657 }
658
659 /* next_descp = (NML_DESC *)((char*) descp + k);*/
660 next_descp = (NML_DESC *)((char *)descp);
661
662 if (descp->ndims == -2) {
663 desc_dims = (__POINT_T *)((char *)descp + sizeof(NML_DESC));
664 if (*desc_dims == 0) {
665 /* $p contains an address of array/scalar */
666 new_addr = *(char **)sb.loc_addr;
667 err = dtio_write_scalar(&next_descp, descp, new_addr, descp->len);
668 if (err)
669 return err;
670 *NextDescp = next_descp;
671 return 0;
672 }
673 }
674
675 if (d == 0) {
676 /*
677 * Reached the first dimension; iterate over the first dimension,
678 * compute the address of each element, and pass each address to
679 * 'eval'.
680 */
681 F90_Desc *sd = get_descriptor(descp);
682 for (sb.idx[0] = sb.sect[0].lwb; sb.idx[0] <= sb.sect[0].upb;
683 sb.idx[0] += sb.sect[0].stride) {
684 new_addr = I8(__fort_local_address)((*(char **)sb.loc_addr), sd,
685 (__INT_T *)&sb.idx[0]);
686 err = dtio_write_scalar(&next_descp, descp, new_addr, descp->len);
687 if (err)
688 return err;
689 }
690 *NextDescp = next_descp;
691 return 0;
692 }
693
694 /* Iterate over the current dimension, and recursively evaluate all
695 * subscripts in the dimensions to the left.
696 */
697 for (sb.idx[d] = sb.sect[d].lwb; sb.idx[d] <= sb.sect[d].upb;
698 sb.idx[d] += sb.sect[d].stride) {
699 err = I8(eval_dtio_sb)(&next_descp, descp, new_addr, d - 1);
700 if (err)
701 return err;
702 }
703 *NextDescp = next_descp;
704 return 0;
705 }
706
707 static int
eval(int v,char * loc_addr,NML_DESC * descp,NML_DESC ** nextdescp)708 eval(int v, char *loc_addr, NML_DESC *descp, NML_DESC **nextdescp)
709 {
710 char *new_addr;
711 new_addr = loc_addr;
712 return I8(eval_sb)(nextdescp, descp, loc_addr, sb.ndims - 1);
713 }
714
715 static int
eval_dtio(int v,char * loc_addr,NML_DESC * descp,NML_DESC ** nextdescp)716 eval_dtio(int v, char *loc_addr, NML_DESC *descp, NML_DESC **nextdescp)
717 {
718 char *new_addr;
719 new_addr = loc_addr;
720 return I8(eval_dtio_sb)(nextdescp, descp, loc_addr, sb.ndims - 1);
721 }
722
723 static int
_f90io_nml_write(NML_GROUP * nmldesc)724 _f90io_nml_write(NML_GROUP *nmldesc) /* namelist group descriptor */
725 {
726 int i;
727 NML_DESC *descp;
728 char tbuf[64]; /* buffer to convert symbol names to upper */
729 int n;
730 int ret_err;
731
732 if (fioFcbTbls.error)
733 return ERR_FLAG;
734
735 /*
736 * f2003 10.10.2.2 L33: Except for coninuation of delimited character
737 * sequences, each output record begins with a blank character.
738 */
739 /* ------ write group name line: */
740
741 for (n = 0; n < (int)nmldesc->nlen; n++) {
742 tbuf[n] = toupper(nmldesc->group[n]);
743 }
744 ret_err = write_item(" &", 2);
745 if (ret_err)
746 return __fortio_error(ret_err);
747 ret_err = write_item(tbuf, nmldesc->nlen);
748 if (ret_err)
749 return __fortio_error(ret_err);
750 ret_err = emit_eol();
751 if (ret_err)
752 return __fortio_error(ret_err);
753 f->nextrec++;
754
755 /* ------ cycle through namelist entities */
756
757 /* point to first descriptor: */
758 descp = (NML_DESC *)((char *)nmldesc + sizeof(NML_GROUP));
759
760 for (i = 0; i < nmldesc->ndesc; i++) {
761 if (i) {
762 if (gbl->decimal == FIO_COMMA)
763 ret_err = write_char(';');
764 else
765 ret_err = write_char(',');
766 if (ret_err)
767 return __fortio_error(ret_err);
768 ret_err = emit_eol();
769 if (ret_err)
770 return __fortio_error(ret_err);
771 f->nextrec++;
772 }
773 need_comma = FALSE;
774 /* write entity name followed by " = " */
775 for (n = 0; n < (int)descp->nlen; n++) {
776 tbuf[n] = toupper(descp->sym[n]);
777 }
778 ret_err = write_char(' ');
779 if (ret_err)
780 return __fortio_error(ret_err);
781 ret_err = write_item(tbuf, descp->nlen);
782 if (ret_err)
783 return __fortio_error(ret_err);
784 ret_err = write_item(" = ", 3);
785 if (ret_err)
786 return __fortio_error(ret_err);
787 skip = descp->nlen + 4;
788 if (descp->ndims == -2) { /* has defined io */
789 I8(fillup_sb)(0, descp, descp->addr);
790 eval_dtio(0, descp->addr, descp, &descp);
791 } else if (descp->ndims == -1) {
792 I8(fillup_sb)(0, descp, descp->addr);
793 eval(0, descp->addr, descp, &descp);
794 } else if (descp->ndims > MAX_DIM) { /* array defined io, dims-30 */
795 ret_err = dtio_write_scalar(&descp, descp, descp->addr, descp->len);
796 } else if (descp->ndims == MAX_DIM) { /* scalar defined io */
797 /* call used defined io */
798 ret_err = dtio_write_scalar(&descp, descp, descp->addr, descp->len);
799 } else {
800 ret_err = write_nml_val(&descp, descp, descp->addr);
801 }
802 if (ret_err)
803 return ret_err;
804 }
805 ret_err = emit_eol();
806 if (ret_err)
807 return __fortio_error(ret_err);
808 f->nextrec++;
809
810 /* write "$end" line: */
811 ret_err = write_item(" /", 2);
812 if (ret_err)
813 return __fortio_error(ret_err);
814 ret_err = emit_eol();
815 if (ret_err)
816 return __fortio_error(ret_err);
817 /* f->nextrec++; (nextrec incremented in rwinit, so omit here) */
818
819 return 0;
820 }
821
822 int
ENTF90IO(NML_WRITE,nml_write)823 ENTF90IO(NML_WRITE, nml_write)(__INT_T *unit, /* unit number */
824 __INT_T *bitv, /* same as for ENTF90IO(open) */
825 __INT_T *iostat, /* same as for ENTF90IO(open) */
826 NML_GROUP *nmldesc) /* namelist group descr */
827 {
828 int s = 0;
829
830 internal_file = FALSE;
831 __fort_status_init(bitv, iostat);
832 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC) {
833 s = _f90io_nmlw_init(unit, 0, bitv, iostat);
834 if (!s)
835 s = _f90io_nml_write(nmldesc);
836 }
837 return DIST_STATUS_BCST(s);
838 }
839
840 int
ENTCRF90IO(NML_WRITE,nml_write)841 ENTCRF90IO(NML_WRITE, nml_write)(__INT_T *unit, /* unit number */
842 __INT_T *bitv, /* same as for ENTF90IO(open) */
843 __INT_T *iostat, /* same as for ENTF90IO(open) */
844 NML_GROUP *nmldesc) /* namelist group descr */
845 {
846 int s;
847
848 internal_file = FALSE;
849 s = _f90io_nmlw_init(unit, 0, bitv, iostat);
850 if (!s)
851 s = _f90io_nml_write(nmldesc);
852 return s;
853 }
854
855 /** \brief Write a namelist group
856 * \param nmldesc - namelist group descriptor
857 */
858 int
ENTF90IO(NMLW,nmlw)859 ENTF90IO(NMLW, nmlw)(NML_GROUP *nmldesc)
860 {
861 int s = 0;
862
863 if (LOCAL_MODE || GET_DIST_LCPU == GET_DIST_IOPROC) {
864 s = _f90io_nml_write(nmldesc);
865 }
866 return DIST_STATUS_BCST(s);
867 }
868
869 int
ENTCRF90IO(NMLW,nmlw)870 ENTCRF90IO(NMLW, nmlw)(NML_GROUP *nmldesc) /* namelist group descriptor */
871 {
872 int s = 0;
873 s = _f90io_nml_write(nmldesc);
874 return s;
875 }
876
877 /* -------------------------------------------------------------------- */
878
879 static int
_f90io_nmlw_end()880 _f90io_nmlw_end()
881 {
882 gbl->decimal = 0;
883 gbl->sign = 0;
884 gbl->round = 0;
885 if (!gbl->same_fcb_idx) {
886 gbl->unit = 0;
887 gbl->iostat = 0;
888 }
889
890 if (fioFcbTbls.error)
891 return ERR_FLAG;
892
893 return 0;
894 }
895
896 /** \brief Terminates a WRITE statement
897 */
898 int
ENTF90IO(NMLW_END,nmlw_end)899 ENTF90IO(NMLW_END, nmlw_end)()
900 {
901 int ioproc, len;
902 int s = 0;
903
904 ioproc = GET_DIST_IOPROC;
905 if (LOCAL_MODE || GET_DIST_LCPU == ioproc) {
906 s = _f90io_nmlw_end();
907 if (internal_file)
908 len = in_recp - internal_unit;
909 }
910 if (!LOCAL_MODE && internal_file) {
911 DIST_RBCSTL(ioproc, &len, 1, 1, __CINT, sizeof(int));
912 DIST_RBCSTL(ioproc, internal_unit, 1, 1, __CHAR, len);
913 }
914 __fortio_errend03();
915 return DIST_STATUS_BCST(s);
916 }
917
918 int
ENTCRF90IO(NMLW_END,nmlw_end)919 ENTCRF90IO(NMLW_END, nmlw_end)()
920 {
921 int s = 0;
922 s = _f90io_nmlw_end();
923 __fortio_errend03();
924 return s;
925 }
926
927 /* -------------------------------------------------------------------- */
928 static int
dtio_write_scalar(NML_DESC ** NextDescp,NML_DESC * descp,char * loc_addr,int dtvsize)929 dtio_write_scalar(NML_DESC **NextDescp, NML_DESC *descp, char *loc_addr,
930 int dtvsize)
931 {
932 static __INT_T internal_unit = -1;
933 __INT_T tmp_iostat = 0;
934 __INT_T *iostat;
935 __INT_T *unit;
936 void (*dtio)(char *, INT *, char *, INT *, INT *, char *, F90_Desc *,
937 F90_Desc *, __CLEN_T, __CLEN_T);
938 char *dtv;
939 F90_Desc *dtv_sd;
940 F90_Desc *vlist_sd;
941 INT *vlist;
942 NML_DESC *next_descp;
943 NML_DESC *start_descp;
944 __CLEN_T iotypelen = 8;
945 __CLEN_T iomsglen = 250;
946 static char iomsg[250];
947 int k, num_consts, ret_err, j;
948 char *iotype = "NAMELIST";
949 char *start_addr;
950 char *mem_addr;
951 __POINT_T *desc_dims, new_ndims;
952 __POINT_T actual_ndims;
953
954 /* if this is array */
955 num_consts = 1;
956 desc_dims = (__POINT_T *)((char *)descp + sizeof(NML_DESC));
957 if (descp->ndims == -1 || descp->ndims == -2) {
958 new_ndims = *(__POINT_T *)((char *)descp + sizeof(__POINT_T));
959 num_consts = nelems_of(descp);
960 } else {
961 num_consts = nelems_of(descp);
962 }
963
964 actual_ndims = 0;
965 if (descp->ndims == -2) {
966 k = sizeof(NML_DESC) + (sizeof(__POINT_T) * 2);
967 } else if (descp->ndims == MAX_DIM) {
968 ACTUAL_NDIMS(actual_ndims);
969 k = sizeof(NML_DESC) + (actual_ndims * sizeof(__POINT_T) * 2);
970 } else if (descp->ndims > MAX_DIM) {
971 ACTUAL_NDIMS(actual_ndims);
972 k = sizeof(NML_DESC) + (actual_ndims * sizeof(__POINT_T) * 2);
973 } else {
974 #if DEBUG
975 printf("ERROR unexpected ndims:%d\n", (int)descp->ndims);
976 #endif
977 return ERR_FLAG;
978 }
979
980 /* next_descp is now at the start of the defined io arguments */
981 next_descp = (NML_DESC *)((char *)descp + k);
982
983 /* after above, next_descp is now at -98, beginning of dinit define io
984 * arguments */
985
986 if (descp->type != __DERIVED) {
987 #if DEBUG
988 printf("ERROR unexpected dtype, expecting derived type\n");
989 #endif
990 return ERR_FLAG;
991 }
992
993 /* move to user defined io read*/
994 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
995 next_descp = (NML_DESC *)desc_dims;
996
997 /* write routine */
998 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
999 next_descp = (NML_DESC *)desc_dims;
1000 dtio = (void *)*(char **)((char *)desc_dims);
1001 #if DEBUG
1002 if ((INT *)dtio == 0) {
1003 printf("ERROR: unable find user defined io write routine \n");
1004 }
1005
1006 #endif
1007
1008 /* dtv */
1009 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
1010 next_descp = (NML_DESC *)desc_dims;
1011 dtv = (char *)*(char **)((char *)desc_dims);
1012 start_addr = (char *)dtv;
1013
1014 /* dtv$sd */
1015 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
1016 next_descp = (NML_DESC *)desc_dims;
1017 dtv_sd = (F90_Desc *)*(char **)((char *)desc_dims);
1018
1019 /* vlist */
1020 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
1021 next_descp = (NML_DESC *)desc_dims;
1022 vlist = (INT *)*(char **)((char *)desc_dims);
1023
1024 /* vlist$sd */
1025 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
1026 next_descp = (NML_DESC *)desc_dims;
1027 vlist_sd = (F90_Desc *)*(char **)((char *)desc_dims);
1028
1029 /* move to next descriptor */
1030 desc_dims = (__POINT_T *)((char *)next_descp + sizeof(__POINT_T));
1031 next_descp = (NML_DESC *)desc_dims;
1032
1033 start_descp = next_descp;
1034 start_addr = loc_addr;
1035 if (gbl->unit)
1036 unit = gbl->unit;
1037 else
1038 unit = &internal_unit;
1039
1040 if (gbl->iostat)
1041 iostat = gbl->iostat;
1042 else
1043 iostat = &tmp_iostat;
1044
1045 for (k = 0; k < num_consts; k++) {
1046 if (need_comma) { /* put out leading blanks: */
1047 /* put commas after each constant except for very, very last: */
1048 if (gbl->decimal == FIO_COMMA) {
1049 ret_err = write_char(';');
1050 } else {
1051 ret_err = write_char(',');
1052 }
1053 if (ret_err)
1054 return __fortio_error(ret_err);
1055 ret_err = emit_eol();
1056 if (ret_err)
1057 return __fortio_error(ret_err);
1058 f->nextrec++;
1059 for (j = 0; j < skip; j++) {
1060 ret_err = write_char(' ');
1061 if (ret_err)
1062 return __fortio_error(ret_err);
1063 }
1064 }
1065
1066 (*dtio)(start_addr, unit, iotype, vlist, iostat, iomsg, dtv_sd, vlist_sd,
1067 iotypelen, iomsglen);
1068 if (*iostat != 0)
1069 return *iostat;
1070 start_addr = start_addr + descp->len;
1071 need_comma = TRUE;
1072 }
1073 *NextDescp = next_descp;
1074 return 0;
1075 }
1076