1 /*********************************************************************
2 * Copyright 1993, UCAR/Unidata
3 * See netcdf/COPYRIGHT file for copying and redistribution conditions.
4 * $Header: /upc/share/CVS/netcdf-3/ncgen3/genlib.c,v 1.54 2009/11/14 22:33:31 dmh Exp $
5 *********************************************************************/
6
7 #include "config.h"
8 #include <stdio.h>
9 #include <stdlib.h>
10 #include <assert.h>
11 #include <string.h>
12 #include <ctype.h> /* for isprint() */
13 #ifndef NO_STDARG
14 #include <stdarg.h>
15 #else
16 /* try varargs instead */
17 #include <varargs.h>
18 #endif /* !NO_STDARG */
19 #include <netcdf.h>
20 #include "generic.h"
21 #include "ncgen.h"
22 #include "genlib.h"
23
24 extern char *netcdf_name; /* output netCDF filename, if on command line. */
25 extern int netcdf_flag;
26 extern int c_flag;
27 extern int fortran_flag;
28 extern int cmode_modifier;
29 extern int nofill_flag;
30
31 int lineno = 1;
32 int derror_count = 0;
33
34
35 /* create netCDF from in-memory structure */
36 static void
gen_netcdf(char * filename)37 gen_netcdf(
38 char *filename) /* name for output netcdf file */
39 {
40 int idim, ivar, iatt;
41 int dimid;
42 int varid;
43 int stat;
44
45 stat = nc_create(filename, cmode_modifier, &ncid);
46 check_err(stat);
47
48 /* define dimensions from info in dims array */
49 for (idim = 0; idim < ndims; idim++) {
50 stat = nc_def_dim(ncid, dims[idim].name, dims[idim].size, &dimid);
51 check_err(stat);
52 }
53
54 /* define variables from info in vars array */
55 for (ivar = 0; ivar < nvars; ivar++) {
56 stat = nc_def_var(ncid,
57 vars[ivar].name,
58 vars[ivar].type,
59 vars[ivar].ndims,
60 vars[ivar].dims,
61 &varid);
62 check_err(stat);
63 }
64
65 /* define attributes from info in atts array */
66 for (iatt = 0; iatt < natts; iatt++) {
67 varid = (atts[iatt].var == -1) ? NC_GLOBAL : atts[iatt].var;
68 switch(atts[iatt].type) {
69 case NC_BYTE:
70 stat = nc_put_att_schar(ncid, varid, atts[iatt].name,
71 atts[iatt].type, atts[iatt].len,
72 (signed char *) atts[iatt].val);
73 break;
74 case NC_CHAR:
75 stat = nc_put_att_text(ncid, varid, atts[iatt].name,
76 atts[iatt].len,
77 (char *) atts[iatt].val);
78 break;
79 case NC_SHORT:
80 stat = nc_put_att_short(ncid, varid, atts[iatt].name,
81 atts[iatt].type, atts[iatt].len,
82 (short *) atts[iatt].val);
83 break;
84 case NC_INT:
85 stat = nc_put_att_int(ncid, varid, atts[iatt].name,
86 atts[iatt].type, atts[iatt].len,
87 (int *) atts[iatt].val);
88 break;
89 case NC_FLOAT:
90 stat = nc_put_att_float(ncid, varid, atts[iatt].name,
91 atts[iatt].type, atts[iatt].len,
92 (float *) atts[iatt].val);
93 break;
94 case NC_DOUBLE:
95 stat = nc_put_att_double(ncid, varid, atts[iatt].name,
96 atts[iatt].type, atts[iatt].len,
97 (double *) atts[iatt].val);
98 break;
99 default:
100 stat = NC_EBADTYPE;
101 }
102 check_err(stat);
103 }
104
105 if (nofill_flag) {
106 stat = nc_set_fill(ncid, NC_NOFILL, 0); /* don't initialize with fill values */
107 check_err(stat);
108 }
109
110 stat = nc_enddef(ncid);
111 check_err(stat);
112 }
113
114
115 /*
116 * Given a netcdf type, a pointer to a vector of values of that type,
117 * and the index of the vector element desired, returns a pointer to a
118 * malloced string representing the value in C.
119 */
120 static char *
cstring(nc_type type,void * valp,int num)121 cstring(
122 nc_type type, /* netCDF type code */
123 void *valp, /* pointer to vector of values */
124 int num) /* element of vector desired */
125 {
126 static char *cp, *sp, ch;
127 signed char *bytep;
128 short *shortp;
129 int *intp;
130 float *floatp;
131 double *doublep;
132
133 switch (type) {
134 case NC_CHAR:
135 sp = cp = (char *) emalloc (7);
136 *cp++ = '\'';
137 ch = *((char *)valp + num);
138 switch (ch) {
139 case '\b': *cp++ = '\\'; *cp++ = 'b'; break;
140 case '\f': *cp++ = '\\'; *cp++ = 'f'; break;
141 case '\n': *cp++ = '\\'; *cp++ = 'n'; break;
142 case '\r': *cp++ = '\\'; *cp++ = 'r'; break;
143 case '\t': *cp++ = '\\'; *cp++ = 't'; break;
144 case '\v': *cp++ = '\\'; *cp++ = 'v'; break;
145 case '\\': *cp++ = '\\'; *cp++ = '\\'; break;
146 case '\'': *cp++ = '\\'; *cp++ = '\''; break;
147 default:
148 if (!isprint((unsigned char)ch)) {
149 static char octs[] = "01234567";
150 int rem = ((unsigned char)ch)%64;
151 *cp++ = '\\';
152 *cp++ = octs[((unsigned char)ch)/64]; /* to get, e.g. '\177' */
153 *cp++ = octs[rem/8];
154 *cp++ = octs[rem%8];
155 } else {
156 *cp++ = ch;
157 }
158 break;
159 }
160 *cp++ = '\'';
161 *cp = '\0';
162 return sp;
163
164 case NC_BYTE:
165 cp = (char *) emalloc (7);
166 bytep = (signed char *)valp;
167 /* Need to convert '\377' to -1, for example, on all platforms */
168 (void) sprintf(cp,"%d", (signed char) *(bytep+num));
169 return cp;
170
171 case NC_SHORT:
172 cp = (char *) emalloc (10);
173 shortp = (short *)valp;
174 (void) sprintf(cp,"%d",* (shortp + num));
175 return cp;
176
177 case NC_INT:
178 cp = (char *) emalloc (20);
179 intp = (int *)valp;
180 (void) sprintf(cp,"%d",* (intp + num));
181 return cp;
182
183 case NC_FLOAT:
184 cp = (char *) emalloc (20);
185 floatp = (float *)valp;
186 (void) sprintf(cp,"%.8g",* (floatp + num));
187 return cp;
188
189 case NC_DOUBLE:
190 cp = (char *) emalloc (20);
191 doublep = (double *)valp;
192 (void) sprintf(cp,"%.16g",* (doublep + num));
193 return cp;
194
195 default:
196 derror("cstring: bad type code");
197 return 0;
198 }
199 }
200
201
202 /*
203 * Generate C code for creating netCDF from in-memory structure.
204 */
205 static void
gen_c(const char * filename)206 gen_c(
207 const char *filename)
208 {
209 int idim, ivar, iatt, jatt, maxdims;
210 int vector_atts;
211 char *val_string;
212 char stmnt[C_MAX_STMNT];
213
214 /* wrap in main program */
215 cline("#include <stdio.h>");
216 cline("#include <stdlib.h>");
217 cline("#include <netcdf.h>");
218 cline("");
219 cline("void");
220 cline("check_err(const int stat, const int line, const char *file) {");
221 cline(" if (stat != NC_NOERR) {");
222 cline(" (void) fprintf(stderr, \"line %d of %s: %s\\n\", line, file, nc_strerror(stat));");
223 cline(" exit(1);");
224 cline(" }");
225 cline("}");
226 cline("");
227 cline("int");
228 sprintf(stmnt, "main() {\t\t\t/* create %s */", filename);
229 cline(stmnt);
230
231 /* create necessary declarations */
232 cline("");
233 cline(" int stat;\t\t\t/* return status */");
234 cline(" int ncid;\t\t\t/* netCDF id */");
235
236 if (ndims > 0) {
237 cline("");
238 cline(" /* dimension ids */");
239 for (idim = 0; idim < ndims; idim++) {
240 sprintf(stmnt, " int %s_dim;", dims[idim].lname);
241 cline(stmnt);
242 }
243
244 cline("");
245 cline(" /* dimension lengths */");
246 for (idim = 0; idim < ndims; idim++) {
247 if (dims[idim].size == NC_UNLIMITED) {
248 sprintf(stmnt, " size_t %s_len = NC_UNLIMITED;",
249 dims[idim].lname);
250 } else {
251 sprintf(stmnt, " size_t %s_len = %lu;",
252 dims[idim].lname,
253 (unsigned long) dims[idim].size);
254 }
255 cline(stmnt);
256 }
257 }
258
259 maxdims = 0; /* most dimensions of any variable */
260 for (ivar = 0; ivar < nvars; ivar++)
261 if (vars[ivar].ndims > maxdims)
262 maxdims = vars[ivar].ndims;
263
264 if (nvars > 0) {
265 cline("");
266 cline(" /* variable ids */");
267 for (ivar = 0; ivar < nvars; ivar++) {
268 sprintf(stmnt, " int %s_id;", vars[ivar].lname);
269 cline(stmnt);
270 }
271
272 cline("");
273 cline(" /* rank (number of dimensions) for each variable */");
274 for (ivar = 0; ivar < nvars; ivar++) {
275 sprintf(stmnt, "# define RANK_%s %d", vars[ivar].lname,
276 vars[ivar].ndims);
277 cline(stmnt);
278 }
279 if (maxdims > 0) { /* we have dimensioned variables */
280 cline("");
281 cline(" /* variable shapes */");
282 for (ivar = 0; ivar < nvars; ivar++) {
283 if (vars[ivar].ndims > 0) {
284 sprintf(stmnt, " int %s_dims[RANK_%s];",
285 vars[ivar].lname, vars[ivar].lname);
286 cline(stmnt);
287 }
288 }
289 }
290 }
291
292 /* determine if we need any attribute vectors */
293 vector_atts = 0;
294 for (iatt = 0; iatt < natts; iatt++) {
295 if (atts[iatt].type != NC_CHAR) {
296 vector_atts = 1;
297 break;
298 }
299 }
300 if (vector_atts) {
301 cline("");
302 cline(" /* attribute vectors */");
303 for (iatt = 0; iatt < natts; iatt++) {
304 if (atts[iatt].type != NC_CHAR) {
305 sprintf(stmnt,
306 " %s %s_%s[%lu];",
307 ncatype(atts[iatt].type),
308 atts[iatt].var == -1 ? "cdf" : vars[atts[iatt].var].lname,
309 atts[iatt].lname,
310 (unsigned long) atts[iatt].len);
311 cline(stmnt);
312 }
313 }
314 }
315
316 /* create netCDF file, uses NC_CLOBBER mode */
317 cline("");
318 cline(" /* enter define mode */");
319
320 if (!cmode_modifier) {
321 sprintf(stmnt,
322 " stat = nc_create(\"%s\", NC_CLOBBER, &ncid);",
323 filename);
324 } else if (cmode_modifier & NC_64BIT_OFFSET) {
325 sprintf(stmnt,
326 " stat = nc_create(\"%s\", NC_CLOBBER|NC_64BIT_OFFSET, &ncid);",
327 filename);
328 #ifdef USE_NETCDF4
329 } else if (cmode_modifier & NC_CLASSIC_MODEL) {
330 sprintf(stmnt,
331 " stat = nc_create(\"%s\", NC_CLOBBER|NC_NETCDF4|NC_CLASSIC_MODEL, &ncid);",
332 filename);
333 } else if (cmode_modifier & NC_NETCDF4) {
334 sprintf(stmnt,
335 " stat = nc_create(\"%s\", NC_CLOBBER|NC_NETCDF4, &ncid);",
336 filename);
337 #endif
338 } else {
339 derror("unknown cmode modifier");
340 }
341 cline(stmnt);
342 cline(" check_err(stat,__LINE__,__FILE__);");
343
344 /* define dimensions from info in dims array */
345 if (ndims > 0) {
346 cline("");
347 cline(" /* define dimensions */");
348 }
349 for (idim = 0; idim < ndims; idim++) {
350 sprintf(stmnt,
351 " stat = nc_def_dim(ncid, \"%s\", %s_len, &%s_dim);",
352 dims[idim].name, dims[idim].lname, dims[idim].lname);
353 cline(stmnt);
354 cline(" check_err(stat,__LINE__,__FILE__);");
355 }
356
357 /* define variables from info in vars array */
358 if (nvars > 0) {
359 cline("");
360 cline(" /* define variables */");
361 for (ivar = 0; ivar < nvars; ivar++) {
362 cline("");
363 for (idim = 0; idim < vars[ivar].ndims; idim++) {
364 sprintf(stmnt,
365 " %s_dims[%d] = %s_dim;",
366 vars[ivar].lname,
367 idim,
368 dims[vars[ivar].dims[idim]].lname);
369 cline(stmnt);
370 }
371 if (vars[ivar].ndims > 0) { /* a dimensioned variable */
372 sprintf(stmnt,
373 " stat = nc_def_var(ncid, \"%s\", %s, RANK_%s, %s_dims, &%s_id);",
374 vars[ivar].name,
375 nctype(vars[ivar].type),
376 vars[ivar].lname,
377 vars[ivar].lname,
378 vars[ivar].lname);
379 } else { /* a scalar */
380 sprintf(stmnt,
381 " stat = nc_def_var(ncid, \"%s\", %s, RANK_%s, 0, &%s_id);",
382 vars[ivar].name,
383 nctype(vars[ivar].type),
384 vars[ivar].lname,
385 vars[ivar].lname);
386 }
387 cline(stmnt);
388 cline(" check_err(stat,__LINE__,__FILE__);");
389 }
390 }
391
392 /* define attributes from info in atts array */
393 if (natts > 0) {
394 cline("");
395 cline(" /* assign attributes */");
396 for (iatt = 0; iatt < natts; iatt++) {
397 if (atts[iatt].type == NC_CHAR) { /* string */
398 val_string = cstrstr((char *) atts[iatt].val, atts[iatt].len);
399 sprintf(stmnt,
400 " stat = nc_put_att_text(ncid, %s%s, \"%s\", %lu, %s);",
401 atts[iatt].var == -1 ? "NC_GLOBAL" : vars[atts[iatt].var].lname,
402 atts[iatt].var == -1 ? "" : "_id",
403 atts[iatt].name,
404 (unsigned long) atts[iatt].len,
405 val_string);
406 cline(stmnt);
407 free (val_string);
408 }
409 else { /* vector attribute */
410 for (jatt = 0; jatt < atts[iatt].len ; jatt++) {
411 val_string = cstring(atts[iatt].type,atts[iatt].val,jatt);
412 sprintf(stmnt, " %s_%s[%d] = %s;",
413 atts[iatt].var == -1 ? "cdf" : vars[atts[iatt].var].lname,
414 atts[iatt].lname,
415 jatt,
416 val_string);
417 cline(stmnt);
418 free (val_string);
419 }
420
421 sprintf(stmnt,
422 " stat = nc_put_att_%s(ncid, %s%s, \"%s\", %s, %lu, %s_%s);",
423 ncatype(atts[iatt].type),
424 atts[iatt].var == -1 ? "NC_GLOBAL" : vars[atts[iatt].var].lname,
425 atts[iatt].var == -1 ? "" : "_id",
426 atts[iatt].name,
427 nctype(atts[iatt].type),
428 (unsigned long) atts[iatt].len,
429 atts[iatt].var == -1 ? "cdf" : vars[atts[iatt].var].lname,
430 atts[iatt].lname);
431 cline(stmnt);
432 }
433 cline(" check_err(stat,__LINE__,__FILE__);");
434 }
435 }
436
437 if (nofill_flag) {
438 cline(" /* don't initialize variables with fill values */");
439 cline(" stat = nc_set_fill(ncid, NC_NOFILL, 0);");
440 cline(" check_err(stat,__LINE__,__FILE__);");
441 }
442
443 cline("");
444 cline(" /* leave define mode */");
445 cline(" stat = nc_enddef (ncid);");
446 cline(" check_err(stat,__LINE__,__FILE__);");
447 }
448
449
450 /* return Fortran type name for netCDF type, given type code */
451 static const char *
ncftype(nc_type type)452 ncftype(
453 nc_type type) /* netCDF type code */
454 {
455 switch (type) {
456
457 case NC_BYTE:
458 return "integer";
459 case NC_CHAR:
460 return "character";
461 case NC_SHORT:
462 return "integer";
463 case NC_INT:
464 #ifdef MSDOS
465 return "integer*4";
466 #else
467 return "integer";
468 #endif
469 case NC_FLOAT:
470 return "real";
471 #if defined(_CRAY) && !defined(__crayx1)
472 case NC_DOUBLE:
473 return "real"; /* we don't support CRAY 128-bit doubles */
474 #else
475 case NC_DOUBLE:
476 return "double precision";
477 #endif
478 default:
479 derror("ncftype: bad type code");
480 return 0;
481
482 }
483 }
484
485
486 /* return Fortran type suffix for netCDF type, given type code */
487 const char *
nfstype(nc_type type)488 nfstype(
489 nc_type type) /* netCDF type code */
490 {
491 switch (type) {
492 case NC_BYTE:
493 return "int1";
494 case NC_CHAR:
495 return "text";
496 case NC_SHORT:
497 return "int2";
498 case NC_INT:
499 return "int";
500 case NC_FLOAT:
501 return "real";
502 case NC_DOUBLE:
503 return "double";
504 default:
505 derror("nfstype: bad type code");
506 return 0;
507
508 }
509 }
510
511
512 /* Return Fortran function suffix for netCDF type, given type code.
513 * This should correspond to the Fortran type name in ncftype().
514 */
515 const char *
nfftype(nc_type type)516 nfftype(
517 nc_type type) /* netCDF type code */
518 {
519 switch (type) {
520 case NC_BYTE:
521 return "int";
522 case NC_CHAR:
523 return "text";
524 case NC_SHORT:
525 return "int";
526 case NC_INT:
527 return "int";
528 case NC_FLOAT:
529 return "real";
530 #if defined(_CRAY) && !defined(__crayx1)
531 case NC_DOUBLE:
532 return "real"; /* we don't support CRAY 128-bit doubles */
533 #else
534 case NC_DOUBLE:
535 return "double";
536 #endif
537 default:
538 derror("nfstype: bad type code");
539 return 0;
540
541 }
542 }
543
544
545 /* return FORTRAN name for netCDF type, given type code */
546 static const char *
ftypename(nc_type type)547 ftypename(
548 nc_type type) /* netCDF type code */
549 {
550 switch (type) {
551 case NC_BYTE:
552 return "NF_INT1";
553 case NC_CHAR:
554 return "NF_CHAR";
555 case NC_SHORT:
556 return "NF_INT2";
557 case NC_INT:
558 return "NF_INT";
559 case NC_FLOAT:
560 return "NF_REAL";
561 case NC_DOUBLE:
562 return "NF_DOUBLE";
563 default:
564 derror("ftypename: bad type code");
565 return 0;
566 }
567 }
568
569
570 /*
571 * Generate FORTRAN code for creating netCDF from in-memory structure.
572 */
573 static void
gen_fortran(const char * filename)574 gen_fortran(
575 const char *filename)
576 {
577 int idim, ivar, iatt, jatt, itype, maxdims;
578 int vector_atts;
579 char *val_string;
580 char stmnt[FORT_MAX_STMNT];
581 char s2[NC_MAX_NAME + 10];
582 char *sp;
583 /* Need how many netCDF types there are, because we create an array
584 * for each type of attribute. */
585 int ntypes = 6; /* number of netCDF types, NC_BYTE, ... */
586 nc_type types[6]; /* at least ntypes */
587 size_t max_atts[NC_DOUBLE + 1];
588
589 types[0] = NC_BYTE;
590 types[1] = NC_CHAR;
591 types[2] = NC_SHORT;
592 types[3] = NC_INT;
593 types[4] = NC_FLOAT;
594 types[5] = NC_DOUBLE;
595
596 fline("program fgennc");
597
598 fline("include 'netcdf.inc'");
599
600 /* create necessary declarations */
601 fline("* error status return");
602 fline("integer iret");
603 fline("* netCDF id");
604 fline("integer ncid");
605 if (nofill_flag) {
606 fline("* to save old fill mode before changing it temporarily");
607 fline("integer oldmode");
608 }
609
610 if (ndims > 0) {
611 fline("* dimension ids");
612 for (idim = 0; idim < ndims; idim++) {
613 sprintf(stmnt, "integer %s_dim", dims[idim].lname);
614 fline(stmnt);
615 }
616
617 fline("* dimension lengths");
618 for (idim = 0; idim < ndims; idim++) {
619 sprintf(stmnt, "integer %s_len", dims[idim].lname);
620 fline(stmnt);
621 }
622 for (idim = 0; idim < ndims; idim++) {
623 if (dims[idim].size == NC_UNLIMITED) {
624 sprintf(stmnt, "parameter (%s_len = NF_UNLIMITED)",
625 dims[idim].lname);
626 } else {
627 sprintf(stmnt, "parameter (%s_len = %lu)",
628 dims[idim].lname,
629 (unsigned long) dims[idim].size);
630 }
631 fline(stmnt);
632 }
633
634 }
635
636 maxdims = 0; /* most dimensions of any variable */
637 for (ivar = 0; ivar < nvars; ivar++)
638 if (vars[ivar].ndims > maxdims)
639 maxdims = vars[ivar].ndims;
640
641 if (nvars > 0) {
642 fline("* variable ids");
643 for (ivar = 0; ivar < nvars; ivar++) {
644 sprintf(stmnt, "integer %s_id", vars[ivar].lname);
645 fline(stmnt);
646 }
647
648 fline("* rank (number of dimensions) for each variable");
649 for (ivar = 0; ivar < nvars; ivar++) {
650 sprintf(stmnt, "integer %s_rank", vars[ivar].lname);
651 fline(stmnt);
652 }
653 for (ivar = 0; ivar < nvars; ivar++) {
654 sprintf(stmnt, "parameter (%s_rank = %d)", vars[ivar].lname,
655 vars[ivar].ndims);
656 fline(stmnt);
657 }
658
659 fline("* variable shapes");
660 for (ivar = 0; ivar < nvars; ivar++) {
661 if (vars[ivar].ndims > 0) {
662 sprintf(stmnt, "integer %s_dims(%s_rank)",
663 vars[ivar].lname, vars[ivar].lname);
664 fline(stmnt);
665 }
666 }
667 }
668
669 /* declarations for variables to be initialized */
670 if (nvars > 0) { /* we have variables */
671 fline("* data variables");
672 for (ivar = 0; ivar < nvars; ivar++) {
673 struct vars *v = &vars[ivar];
674 /* Generate declarations here for non-record data variables only.
675 Record variables are declared in separate subroutine later,
676 when we know how big they are. */
677 if (v->ndims > 0 && v->dims[0] == rec_dim) {
678 continue;
679 }
680 /* Make declarations for non-text variables only;
681 for text variables, just include string in nf_put_var call */
682 if (v->type == NC_CHAR) {
683 continue;
684 }
685 if (v->ndims == 0) { /* scalar */
686 sprintf(stmnt, "%s %s", ncftype(v->type),
687 v->lname);
688 } else {
689 sprintf(stmnt, "%s %s(", ncftype(v->type),
690 v->lname);
691 /* reverse dimensions for FORTRAN */
692 for (idim = v->ndims-1; idim >= 0; idim--) {
693 sprintf(s2, "%s_len, ",
694 dims[v->dims[idim]].lname);
695 strcat(stmnt, s2);
696 }
697 sp = strrchr(stmnt, ',');
698 if(sp != NULL) {
699 *sp = '\0';
700 }
701 strcat(stmnt, ")");
702 }
703 fline(stmnt);
704 }
705 }
706
707 /* determine what attribute vectors needed */
708 for (itype = 0; itype < ntypes; itype++)
709 max_atts[(int)types[itype]] = 0;
710
711 vector_atts = 0;
712 for (iatt = 0; iatt < natts; iatt++) {
713 if (atts[iatt].len > max_atts[(int) atts[iatt].type]) {
714 max_atts[(int)atts[iatt].type] = atts[iatt].len;
715 vector_atts = 1;
716 }
717 }
718 if (vector_atts) {
719 fline("* attribute vectors");
720 for (itype = 0; itype < ntypes; itype++) {
721 if (types[itype] != NC_CHAR && max_atts[(int)types[itype]] > 0) {
722 sprintf(stmnt, "%s %sval(%lu)", ncftype(types[itype]),
723 nfstype(types[itype]),
724 (unsigned long) max_atts[(int)types[itype]]);
725 fline(stmnt);
726 }
727 }
728 }
729
730 /* create netCDF file, uses NC_CLOBBER mode */
731 fline("* enter define mode");
732 if (!cmode_modifier) {
733 sprintf(stmnt, "iret = nf_create(\'%s\', NF_CLOBBER, ncid)", filename);
734 } else if (cmode_modifier & NC_64BIT_OFFSET) {
735 sprintf(stmnt, "iret = nf_create(\'%s\', OR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)", filename);
736 #ifdef USE_NETCDF4
737 } else if (cmode_modifier & NC_CLASSIC_MODEL) {
738 sprintf(stmnt, "iret = nf_create(\'%s\', OR(NF_CLOBBER,NC_NETCDF4,NC_CLASSIC_MODEL), ncid)", filename);
739 } else if (cmode_modifier & NC_NETCDF4) {
740 sprintf(stmnt, "iret = nf_create(\'%s\', OR(NF_CLOBBER,NF_NETCDF4), ncid)", filename);
741 #endif
742 } else {
743 derror("unknown cmode modifier");
744 }
745 fline(stmnt);
746 fline("call check_err(iret)");
747
748 /* define dimensions from info in dims array */
749 if (ndims > 0)
750 fline("* define dimensions");
751 for (idim = 0; idim < ndims; idim++) {
752 if (dims[idim].size == NC_UNLIMITED)
753 sprintf(stmnt, "iret = nf_def_dim(ncid, \'%s\', NF_UNLIMITED, %s_dim)",
754 dims[idim].name, dims[idim].lname);
755 else
756 sprintf(stmnt, "iret = nf_def_dim(ncid, \'%s\', %lu, %s_dim)",
757 dims[idim].name, (unsigned long) dims[idim].size,
758 dims[idim].lname);
759 fline(stmnt);
760 fline("call check_err(iret)");
761 }
762
763 /* define variables from info in vars array */
764 if (nvars > 0) {
765 fline("* define variables");
766 for (ivar = 0; ivar < nvars; ivar++) {
767 for (idim = 0; idim < vars[ivar].ndims; idim++) {
768 sprintf(stmnt, "%s_dims(%d) = %s_dim",
769 vars[ivar].lname,
770 vars[ivar].ndims - idim, /* reverse dimensions */
771 dims[vars[ivar].dims[idim]].lname);
772 fline(stmnt);
773 }
774 if (vars[ivar].ndims > 0) { /* a dimensioned variable */
775 sprintf(stmnt,
776 "iret = nf_def_var(ncid, \'%s\', %s, %s_rank, %s_dims, %s_id)",
777 vars[ivar].name,
778 ftypename(vars[ivar].type),
779 vars[ivar].lname,
780 vars[ivar].lname,
781 vars[ivar].lname);
782 } else { /* a scalar */
783 sprintf(stmnt,
784 "iret = nf_def_var(ncid, \'%s\', %s, %s_rank, 0, %s_id)",
785 vars[ivar].name,
786 ftypename(vars[ivar].type),
787 vars[ivar].lname,
788 vars[ivar].lname);
789 }
790 fline(stmnt);
791 fline("call check_err(iret)");
792 }
793 }
794
795 /* define attributes from info in atts array */
796 if (natts > 0) {
797 fline("* assign attributes");
798 for (iatt = 0; iatt < natts; iatt++) {
799 if (atts[iatt].type == NC_CHAR) { /* string */
800 val_string = fstrstr((char *) atts[iatt].val, atts[iatt].len);
801 sprintf(stmnt,
802 "iret = nf_put_att_text(ncid, %s%s, \'%s\', %lu, %s)",
803 atts[iatt].var == -1 ? "NF_GLOBAL" : vars[atts[iatt].var].lname,
804 atts[iatt].var == -1 ? "" : "_id",
805 atts[iatt].name,
806 (unsigned long) atts[iatt].len,
807 val_string);
808 fline(stmnt);
809 fline("call check_err(iret)");
810 free(val_string);
811 } else {
812 for (jatt = 0; jatt < atts[iatt].len ; jatt++) {
813 val_string = fstring(atts[iatt].type,atts[iatt].val,jatt);
814 sprintf(stmnt, "%sval(%d) = %s",
815 nfstype(atts[iatt].type),
816 jatt+1,
817 val_string);
818 fline(stmnt);
819 free (val_string);
820 }
821
822 sprintf(stmnt,
823 "iret = nf_put_att_%s(ncid, %s%s, \'%s\', %s, %lu, %sval)",
824 nfftype(atts[iatt].type),
825 atts[iatt].var == -1 ? "NCGLOBAL" : vars[atts[iatt].var].lname,
826 atts[iatt].var == -1 ? "" : "_id",
827 atts[iatt].name,
828 ftypename(atts[iatt].type),
829 (unsigned long) atts[iatt].len,
830 nfstype(atts[iatt].type));
831 fline(stmnt);
832 fline("call check_err(iret)");
833 }
834 }
835 }
836
837 if (nofill_flag) {
838 fline("* don't initialize variables with fill values");
839 fline("iret = nf_set_fill(ncid, NF_NOFILL, oldmode)");
840 fline("call check_err(iret)");
841 }
842
843 fline("* leave define mode");
844 fline("iret = nf_enddef(ncid)");
845 fline("call check_err(iret)");
846 }
847
848
849 /*
850 * Output a C statement.
851 */
852 void
cline(const char * stmnt)853 cline(
854 const char *stmnt)
855 {
856 FILE *cout = stdout;
857
858 fputs(stmnt, cout);
859 fputs("\n", cout);
860 }
861
862 /*
863 * From a long line FORTRAN statement, generates the necessary FORTRAN
864 * lines with continuation characters in column 6. If stmnt starts with "*",
865 * it is treated as a one-line comment. Statement labels are *not* handled,
866 * but since we don't generate any labels, we don't care.
867 */
868 void
fline(const char * stmnt)869 fline(
870 const char *stmnt)
871 {
872 FILE *fout = stdout;
873 int len = (int) strlen(stmnt);
874 int line = 0;
875 static char cont[] = { /* continuation characters */
876 ' ', '1', '2', '3', '4', '5', '6', '7', '8', '9',
877 '+', '1', '2', '3', '4', '5', '6', '7', '8', '9',
878 '+', '1', '2', '3', '4', '5', '6', '7', '8', '9'};
879
880 if(stmnt[0] == '*') {
881 fputs(stmnt, fout);
882 fputs("\n", fout);
883 return;
884 }
885
886 while (len > 0) {
887 if (line >= FORT_MAX_LINES)
888 derror("FORTRAN statement too long: %s",stmnt);
889 (void) fprintf(fout, " %c", cont[line++]);
890 (void) fprintf(fout, "%.66s\n", stmnt);
891 len -= 66;
892 if (len > 0)
893 stmnt += 66;
894 }
895 }
896
897
898 /* return C name for netCDF type, given type code */
899 const char *
nctype(nc_type type)900 nctype(
901 nc_type type) /* netCDF type code */
902 {
903 switch (type) {
904 case NC_BYTE:
905 return "NC_BYTE";
906 case NC_CHAR:
907 return "NC_CHAR";
908 case NC_SHORT:
909 return "NC_SHORT";
910 case NC_INT:
911 return "NC_INT";
912 case NC_FLOAT:
913 return "NC_FLOAT";
914 case NC_DOUBLE:
915 return "NC_DOUBLE";
916 default:
917 derror("nctype: bad type code");
918 return 0;
919 }
920 }
921
922
923 /*
924 * Return C type name for netCDF type, given type code.
925 */
926 const char *
ncctype(nc_type type)927 ncctype(
928 nc_type type) /* netCDF type code */
929 {
930 switch (type) {
931 case NC_BYTE:
932 return "signed char";
933 case NC_CHAR:
934 return "char";
935 case NC_SHORT:
936 return "short";
937 case NC_INT:
938 return "int";
939 case NC_FLOAT:
940 return "float";
941 case NC_DOUBLE:
942 return "double";
943 default:
944 derror("ncctype: bad type code");
945 return 0;
946 }
947 }
948
949
950
951 /*
952 * Return C type name for netCDF type suffix, given type code.
953 */
954 const char *
ncstype(nc_type type)955 ncstype(
956 nc_type type) /* netCDF type code */
957 {
958 switch (type) {
959 case NC_BYTE:
960 return "schar";
961 case NC_CHAR:
962 return "text";
963 case NC_SHORT:
964 return "short";
965 case NC_INT:
966 return "int";
967 case NC_FLOAT:
968 return "float";
969 case NC_DOUBLE:
970 return "double";
971 default:
972 derror("ncstype: bad type code");
973 return 0;
974 }
975 }
976
977
978 /*
979 * Return C type name for netCDF attribute container type, given type code.
980 */
981 const char *
ncatype(nc_type type)982 ncatype(
983 nc_type type) /* netCDF type code */
984 {
985 switch (type) {
986 case NC_BYTE:
987 return "int"; /* avoids choosing between uchar and schar */
988 case NC_CHAR:
989 return "text";
990 case NC_SHORT:
991 return "short";
992 case NC_INT:
993 return "int";
994 case NC_FLOAT:
995 return "float";
996 case NC_DOUBLE:
997 return "double";
998 default:
999 derror("ncatype: bad type code");
1000 return 0;
1001 }
1002 }
1003
1004
1005 /* return internal size for values of specified netCDF type */
1006 size_t
nctypesize(nc_type type)1007 nctypesize(
1008 nc_type type) /* netCDF type code */
1009 {
1010 switch (type) {
1011 case NC_BYTE:
1012 return sizeof(char);
1013 case NC_CHAR:
1014 return sizeof(char);
1015 case NC_SHORT:
1016 return sizeof(short);
1017 case NC_INT:
1018 return sizeof(int);
1019 case NC_FLOAT:
1020 return sizeof(float);
1021 case NC_DOUBLE:
1022 return sizeof(double);
1023 default:
1024 derror("nctypesize: bad type code");
1025 return 0;
1026 }
1027 }
1028
1029
1030 /*
1031 * Given a netcdf numeric type, a pointer to a vector of values of that
1032 * type, and the index of the vector element desired, returns a pointer
1033 * to a malloced string representing the value in FORTRAN. Since this
1034 * may be used in a DATA statement, it must not include non-constant
1035 * expressions, such as "char(26)".
1036 */
1037 char *
fstring(nc_type type,void * valp,int num)1038 fstring(
1039 nc_type type, /* netCDF type code */
1040 void *valp, /* pointer to vector of values */
1041 int num) /* element of vector desired */
1042 {
1043 static char *cp;
1044 signed char *schp;
1045 short *shortp;
1046 int *intp;
1047 float *floatp;
1048 double *doublep;
1049
1050 switch (type) {
1051 case NC_BYTE:
1052 cp = (char *) emalloc (10);
1053 schp = (signed char *)valp;
1054 sprintf(cp,"%d", schp[num]);
1055 return cp;
1056
1057 case NC_SHORT:
1058 cp = (char *) emalloc (10);
1059 shortp = (short *)valp;
1060 (void) sprintf(cp,"%d",* (shortp + num));
1061 return cp;
1062
1063 case NC_INT:
1064 cp = (char *) emalloc (20);
1065 intp = (int *)valp;
1066 (void) sprintf(cp,"%d",* (intp + num));
1067 return cp;
1068
1069 case NC_FLOAT:
1070 cp = (char *) emalloc (20);
1071 floatp = (float *)valp;
1072 (void) sprintf(cp,"%.8g",* (floatp + num));
1073 return cp;
1074
1075 case NC_DOUBLE:
1076 cp = (char *) emalloc (25);
1077 doublep = (double *)valp;
1078 (void) sprintf(cp,"%.16g",* (doublep + num));
1079 expe2d(cp); /* change 'e' to 'd' in exponent */
1080 return cp;
1081
1082 default:
1083 derror("fstring: bad type code");
1084 return 0;
1085 }
1086 }
1087
1088
1089 /*
1090 * Given a pointer to a counted string, returns a pointer to a malloced string
1091 * representing the string as a C constant.
1092 */
1093 char *
cstrstr(const char * valp,size_t len)1094 cstrstr(
1095 const char *valp, /* pointer to vector of characters*/
1096 size_t len) /* number of characters in valp */
1097 {
1098 static char *sp;
1099 char *cp;
1100 char *istr, *istr0; /* for null-terminated copy */
1101 int ii;
1102
1103 if(4*len+3 != (unsigned)(4*len+3)) {
1104 derror("too much character data!");
1105 exit(9);
1106 }
1107 sp = cp = (char *) emalloc(4*len+3);
1108
1109 if(len == 1 && *valp == 0) { /* empty string */
1110 strcpy(sp,"\"\"");
1111 return sp;
1112 }
1113
1114 istr0 = istr = (char *) emalloc(len + 1);
1115 for(ii = 0; ii < len; ii++) {
1116 istr[ii] = valp[ii];
1117 }
1118 istr[len] = '\0';
1119
1120 *cp++ = '"';
1121 for(ii = 0; ii < len; ii++) {
1122 switch (*istr) {
1123 case '\0': *cp++ = '\\'; *cp++ = '0'; *cp++ = '0'; *cp++ = '0'; break;
1124 case '\b': *cp++ = '\\'; *cp++ = 'b'; break;
1125 case '\f': *cp++ = '\\'; *cp++ = 'f'; break;
1126 case '\n': *cp++ = '\\'; *cp++ = 'n'; break;
1127 case '\r': *cp++ = '\\'; *cp++ = 'r'; break;
1128 case '\t': *cp++ = '\\'; *cp++ = 't'; break;
1129 case '\v': *cp++ = '\\'; *cp++ = 'v'; break;
1130 case '\\': *cp++ = '\\'; *cp++ = '\\'; break;
1131 case '\"': *cp++ = '\\'; *cp++ = '\"'; break;
1132 default:
1133 if (!isprint((unsigned char)*istr)) {
1134 static char octs[] = "01234567";
1135 int rem = ((unsigned char)*istr)%64;
1136 *cp++ = '\\';
1137 *cp++ = octs[((unsigned char)*istr)/64]; /* to get, e.g. '\177' */
1138 *cp++ = octs[rem/8];
1139 *cp++ = octs[rem%8];
1140 } else {
1141 *cp++ = *istr;
1142 }
1143 break;
1144 }
1145 istr++;
1146 }
1147 *cp++ = '"';
1148 *cp = '\0';
1149 free(istr0);
1150 return sp;
1151 }
1152
1153
1154 /* Given a pointer to a counted string (not necessarily
1155 * null-terminated), returns a pointer to a malloced string representing
1156 * the string as a FORTRAN string expression. For example, the string
1157 * "don't" would yield the FORTRAN string "'don''t'", and the string
1158 * "ab\ncd" would yield "'ab'//char(10)//'cd'". The common
1159 * interpretation of "\"-escaped characters is non-standard, so the
1160 * generated Fortran may require adjustment in compilers that don't
1161 * recognize "\" as anything special in a character context. */
1162 char *
fstrstr(const char * str,size_t ilen)1163 fstrstr(
1164 const char *str, /* pointer to vector of characters */
1165 size_t ilen) /* number of characters in istr */
1166 {
1167 static char *ostr;
1168 char *cp, tstr[12];
1169 int was_print = 0; /* true if last character was printable */
1170 char *istr, *istr0; /* for null-terminated copy */
1171 int ii;
1172
1173 if(12*ilen != (size_t)(12*ilen)) {
1174 derror("too much character data!");
1175 exit(9);
1176 }
1177 istr0 = istr = (char *) emalloc(ilen + 1);
1178 for(ii = 0; ii < ilen; ii++) {
1179 istr[ii] = str[ii];
1180 }
1181 istr[ilen] = '\0';
1182
1183 if (*istr == '\0') { /* empty string input, not legal in FORTRAN */
1184 ostr = (char*) emalloc(strlen("char(0)") + 1);
1185 strcpy(ostr, "char(0)");
1186 free(istr0);
1187 return ostr;
1188 }
1189 ostr = cp = (char *) emalloc(12*ilen);
1190 *ostr = '\0';
1191 if (isprint((unsigned char)*istr)) { /* handle first character in input */
1192 *cp++ = '\'';
1193 switch (*istr) {
1194 case '\'':
1195 *cp++ = '\'';
1196 *cp++ = '\'';
1197 break;
1198 case '\\':
1199 *cp++ = '\\';
1200 *cp++ = '\\';
1201 break;
1202 default:
1203 *cp++ = *istr;
1204 break;
1205 }
1206 *cp = '\0';
1207 was_print = 1;
1208 } else {
1209 sprintf(tstr, "char(%d)", (unsigned char)*istr);
1210 strcat(cp, tstr);
1211 cp += strlen(tstr);
1212 was_print = 0;
1213 }
1214 istr++;
1215
1216 for(ii = 1; ii < ilen; ii++) { /* handle subsequent characters in input */
1217 if (isprint((unsigned char)*istr)) {
1218 if (! was_print) {
1219 strcat(cp, "//'");
1220 cp += 3;
1221 }
1222 switch (*istr) {
1223 case '\'':
1224 *cp++ = '\'';
1225 *cp++ = '\'';
1226 break;
1227 case '\\':
1228 *cp++ = '\\';
1229 *cp++ = '\\';
1230 break;
1231 default:
1232 *cp++ = *istr;
1233 break;
1234 }
1235 *cp = '\0';
1236 was_print = 1;
1237 } else {
1238 if (was_print) {
1239 *cp++ = '\'';
1240 *cp = '\0';
1241 }
1242 sprintf(tstr, "//char(%d)", (unsigned char)*istr);
1243 strcat(cp, tstr);
1244 cp += strlen(tstr);
1245 was_print = 0;
1246 }
1247 istr++;
1248 }
1249 if (was_print)
1250 *cp++ = '\'';
1251 *cp = '\0';
1252 free(istr0);
1253 return ostr;
1254 }
1255
1256
1257 static void
cl_netcdf(void)1258 cl_netcdf(void)
1259 {
1260 int stat = nc_close(ncid);
1261 check_err(stat);
1262 }
1263
1264
1265 static void
cl_c(void)1266 cl_c(void)
1267 {
1268 cline(" stat = nc_close(ncid);");
1269 cline(" check_err(stat,__LINE__,__FILE__);");
1270 #ifndef vms
1271 cline(" return 0;");
1272 #else
1273 cline(" return 1;");
1274 #endif
1275 cline("}");
1276 }
1277
1278 /* Returns true if dimension used in at least one record variable,
1279 otherwise false. This is an inefficient algorithm, but we don't call
1280 it very often ... */
1281 static int
used_in_rec_var(int idim)1282 used_in_rec_var(
1283 int idim /* id of dimension */
1284 ) {
1285 int ivar;
1286
1287 for (ivar = 0; ivar < nvars; ivar++) {
1288 if (vars[ivar].ndims > 0 && vars[ivar].dims[0] == rec_dim) {
1289 int jdim;
1290 for (jdim = 0; jdim < vars[ivar].ndims; jdim++) {
1291 if (vars[ivar].dims[jdim] == idim)
1292 return 1;
1293 }
1294 }
1295 }
1296 return 0;
1297 }
1298
1299
1300 /* Return name for Fortran fill constant of specified type */
1301 static const char *
f_fill_name(nc_type type)1302 f_fill_name(
1303 nc_type type
1304 )
1305 {
1306 switch(type) {
1307 case NC_BYTE:
1308 return "NF_FILL_BYTE";
1309 case NC_CHAR:
1310 return "NF_FILL_CHAR";
1311 case NC_SHORT:
1312 return "NF_FILL_SHORT";
1313 case NC_INT:
1314 return "NF_FILL_INT";
1315 case NC_FLOAT:
1316 return "NF_FILL_FLOAT";
1317 case NC_DOUBLE:
1318 return "NF_FILL_DOUBLE";
1319 default: break;
1320 }
1321 derror("f_fill_name: bad type code");
1322 return 0;
1323 }
1324
1325
1326 /* Generate Fortran for cleaning up and closing file */
1327 static void
cl_fortran(void)1328 cl_fortran(void)
1329 {
1330 int ivar;
1331 int idim;
1332 char stmnt[FORT_MAX_STMNT];
1333 char s2[FORT_MAX_STMNT];
1334 char*sp;
1335 int have_rec_var = 0;
1336
1337 /* do we have any record variables? */
1338 for (ivar = 0; ivar < nvars; ivar++) {
1339 struct vars *v = &vars[ivar];
1340 if (v->ndims > 0 && v->dims[0] == rec_dim) {
1341 have_rec_var = 1;
1342 break;
1343 }
1344 }
1345
1346 if (have_rec_var) {
1347 fline(" ");
1348 fline("* Write record variables");
1349 sprintf(stmnt, "call writerecs(ncid,");
1350 /* generate parameter list for subroutine to write record vars */
1351 for (ivar = 0; ivar < nvars; ivar++) {
1352 struct vars *v = &vars[ivar];
1353 /* if a record variable, include id in parameter list */
1354 if (v->ndims > 0 && v->dims[0] == rec_dim) {
1355 sprintf(s2, "%s_id,", v->lname);
1356 strcat(stmnt, s2);
1357 }
1358 }
1359 sp = strrchr(stmnt, ',');
1360 if(sp != NULL) {
1361 *sp = '\0';
1362 }
1363 strcat(stmnt, ")");
1364 fline(stmnt);
1365 }
1366
1367 fline(" ");
1368 fline("iret = nf_close(ncid)");
1369 fline("call check_err(iret)");
1370 fline("end");
1371
1372 fline(" ");
1373
1374 if (have_rec_var) {
1375 sprintf(stmnt, "subroutine writerecs(ncid,");
1376 for (ivar = 0; ivar < nvars; ivar++) {
1377 struct vars *v = &vars[ivar];
1378 if (v->ndims > 0 && v->dims[0] == rec_dim) {
1379 sprintf(s2, "%s_id,", v->lname);
1380 strcat(stmnt, s2);
1381 }
1382 }
1383 sp = strrchr(stmnt, ',');
1384 if(sp != NULL) {
1385 *sp = '\0';
1386 }
1387 strcat(stmnt, ")");
1388 fline(stmnt);
1389 fline(" ");
1390 fline("* netCDF id");
1391 fline("integer ncid");
1392
1393 fline("* variable ids");
1394 for (ivar = 0; ivar < nvars; ivar++) {
1395 struct vars *v = &vars[ivar];
1396 if (v->ndims > 0 && v->dims[0] == rec_dim) {
1397 sprintf(stmnt, "integer %s_id", v->lname);
1398 fline(stmnt);
1399 }
1400 }
1401
1402 fline(" ");
1403 fline("include 'netcdf.inc'");
1404
1405 /* create necessary declarations */
1406 fline("* error status return");
1407 fline("integer iret");
1408
1409 /* generate integer/parameter declarations for all dimensions
1410 used in record variables, except record dimension. */
1411 fline(" ");
1412 fline("* netCDF dimension sizes for dimensions used with record variables");
1413 for (idim = 0; idim < ndims; idim++) {
1414 /* if used in a record variable and not record dimension */
1415 if (used_in_rec_var(idim) && dims[idim].size != NC_UNLIMITED) {
1416 sprintf(stmnt, "integer %s_len", dims[idim].lname);
1417 fline(stmnt);
1418 sprintf(stmnt, "parameter (%s_len = %lu)",
1419 dims[idim].lname, (unsigned long) dims[idim].size);
1420 fline(stmnt);
1421 }
1422 }
1423
1424 fline(" ");
1425 fline("* rank (number of dimensions) for each variable");
1426 for (ivar = 0; ivar < nvars; ivar++) {
1427 struct vars *v = &vars[ivar];
1428 if (v->ndims > 0 && v->dims[0] == rec_dim) {
1429 sprintf(stmnt, "integer %s_rank", v->lname);
1430 fline(stmnt);
1431 }
1432 }
1433 for (ivar = 0; ivar < nvars; ivar++) {
1434 struct vars *v = &vars[ivar];
1435 if (v->ndims > 0 && v->dims[0] == rec_dim) {
1436 sprintf(stmnt, "parameter (%s_rank = %d)", v->lname,
1437 v->ndims);
1438 fline(stmnt);
1439 }
1440 }
1441
1442 fline("* starts and counts for array sections of record variables");
1443 for (ivar = 0; ivar < nvars; ivar++) {
1444 struct vars *v = &vars[ivar];
1445 if (v->ndims > 0 && v->dims[0] == rec_dim) {
1446 sprintf(stmnt,
1447 "integer %s_start(%s_rank), %s_count(%s_rank)",
1448 v->lname, v->lname, v->lname, v->lname);
1449 fline(stmnt);
1450 }
1451 }
1452
1453 fline(" ");
1454 fline("* data variables");
1455
1456 for (ivar = 0; ivar < nvars; ivar++) {
1457 struct vars *v = &vars[ivar];
1458 if (v->ndims > 0 && v->dims[0] == rec_dim) {
1459 char *sp;
1460
1461 fline(" ");
1462 sprintf(stmnt, "integer %s_nr", v->lname);
1463 fline(stmnt);
1464 if (v->nrecs > 0) {
1465 sprintf(stmnt, "parameter (%s_nr = %lu)",
1466 v->lname, (unsigned long) v->nrecs);
1467 } else {
1468 sprintf(stmnt, "parameter (%s_nr = 1)",
1469 v->lname);
1470 }
1471 fline(stmnt);
1472 if (v->type != NC_CHAR) {
1473 sprintf(stmnt, "%s %s(", ncftype(v->type),
1474 v->lname);
1475 /* reverse dimensions for FORTRAN */
1476 for (idim = v->ndims-1; idim >= 0; idim--) {
1477 if(v->dims[idim] == rec_dim) {
1478 sprintf(s2, "%s_nr, ", v->lname);
1479 } else {
1480 sprintf(s2, "%s_len, ",
1481 dims[v->dims[idim]].lname);
1482 }
1483 strcat(stmnt, s2);
1484 }
1485 sp = strrchr(stmnt, ',');
1486 if(sp != NULL) {
1487 *sp = '\0';
1488 }
1489 strcat(stmnt, ")");
1490 fline(stmnt);
1491 }
1492 }
1493 }
1494
1495 fline(" ");
1496
1497 /* Emit DATA statements after declarations, because f2c on Linux can't
1498 handle interspersing them */
1499 for (ivar = 0; ivar < nvars; ivar++) {
1500 struct vars *v = &vars[ivar];
1501
1502 if (v->ndims > 0 && v->dims[0] == rec_dim && v->type != NC_CHAR) {
1503 if (v->has_data) {
1504 fline(v->data_stmnt);
1505 } else { /* generate data statement for FILL record */
1506 size_t rec_len = 1;
1507 for (idim = 1; idim < v->ndims; idim++) {
1508 rec_len *= dims[v->dims[idim]].size;
1509 }
1510 sprintf(stmnt,"data %s /%lu * %s/", v->lname,
1511 (unsigned long) rec_len,
1512 f_fill_name(v->type));
1513 fline(stmnt);
1514 }
1515 }
1516 }
1517 fline(" ");
1518 for (ivar = 0; ivar < nvars; ivar++) {
1519 struct vars *v = &vars[ivar];
1520 /* if a record variable, declare starts and counts */
1521 if (v->ndims > 0 && v->dims[0] == rec_dim) {
1522 if (!v->has_data)
1523 continue;
1524 sprintf(stmnt, "* store %s", v->name);
1525 fline(stmnt);
1526
1527 for (idim = 0; idim < v->ndims; idim++) {
1528 sprintf(stmnt, "%s_start(%d) = 1", v->lname, idim+1);
1529 fline(stmnt);
1530 }
1531 for (idim = v->ndims-1; idim > 0; idim--) {
1532 sprintf(stmnt, "%s_count(%d) = %s_len", v->lname,
1533 v->ndims - idim, dims[v->dims[idim]].lname);
1534 fline(stmnt);
1535 }
1536 sprintf(stmnt, "%s_count(%d) = %s_nr", v->lname,
1537 v->ndims, v->lname);
1538 fline(stmnt);
1539
1540 if (v->type != NC_CHAR) {
1541 sprintf(stmnt,
1542 "iret = nf_put_vara_%s(ncid, %s_id, %s_start, %s_count, %s)",
1543 nfftype(v->type), v->lname, v->lname, v->lname, v->lname);
1544 } else {
1545 sprintf(stmnt,
1546 "iret = nf_put_vara_%s(ncid, %s_id, %s_start, %s_count, %s)",
1547 nfftype(v->type), v->lname, v->lname, v->lname,
1548 v->data_stmnt);
1549 }
1550
1551 fline(stmnt);
1552 fline("call check_err(iret)");
1553 }
1554 }
1555
1556 fline(" ");
1557
1558 fline("end");
1559
1560 fline(" ");
1561 }
1562
1563 fline("subroutine check_err(iret)");
1564 fline("integer iret");
1565 fline("include 'netcdf.inc'");
1566 fline("if (iret .ne. NF_NOERR) then");
1567 fline("print *, nf_strerror(iret)");
1568 fline("stop");
1569 fline("endif");
1570 fline("end");
1571 }
1572
1573
1574 /* invoke netcdf calls (or generate C or Fortran code) to create netcdf
1575 * from in-memory structure. */
1576 void
define_netcdf(const char * netcdfname)1577 define_netcdf(
1578 const char *netcdfname)
1579 {
1580 char *filename; /* output file name */
1581
1582 if (netcdf_name) { /* name given on command line */
1583 filename = netcdf_name;
1584 } else { /* construct name from CDL name */
1585 filename = (char *) emalloc(strlen(netcdfname) + 5);
1586 (void) strcpy(filename,netcdfname);
1587 if (netcdf_flag == -1)
1588 (void) strcat(filename,".cdf"); /* old, deprecated extension */
1589 else
1590 (void) strcat(filename,".nc"); /* new, favored extension */
1591 }
1592 if (netcdf_flag)
1593 gen_netcdf(filename); /* create netcdf */
1594 if (c_flag) /* create C code to create netcdf */
1595 gen_c(filename);
1596 if (fortran_flag) /* create Fortran code to create netcdf */
1597 gen_fortran(filename);
1598 free(filename);
1599 }
1600
1601
1602 void
close_netcdf(void)1603 close_netcdf(void)
1604 {
1605 if (netcdf_flag)
1606 cl_netcdf(); /* close netcdf */
1607 if (c_flag) /* create C code to close netcdf */
1608 cl_c();
1609 if (fortran_flag) /* create Fortran code to close netcdf */
1610 cl_fortran();
1611 }
1612
1613
1614 void
check_err(int stat)1615 check_err(int stat) {
1616 if (stat != NC_NOERR) {
1617 fprintf(stderr, "ncgen: %s\n", nc_strerror(stat));
1618 derror_count++;
1619 }
1620 }
1621
1622 /*
1623 * For logging error conditions.
1624 */
1625 #ifndef NO_STDARG
1626 void
derror(const char * fmt,...)1627 derror(const char *fmt, ...)
1628 #else
1629 /*VARARGS1*/
1630 void
1631 derror(fmt, va_alist)
1632 const char *fmt ; /* error-message printf-style format */
1633 va_dcl /* variable number of error args, if any */
1634 #endif /* !NO_STDARG */
1635 {
1636 va_list args ;
1637
1638
1639 if (lineno == 1)
1640 (void) fprintf(stderr,"%s: %s: ", progname, cdlname);
1641 else
1642 (void) fprintf(stderr,"%s: %s line %d: ", progname, cdlname, lineno);
1643
1644 #ifndef NO_STDARG
1645 va_start(args ,fmt) ;
1646 #else
1647 va_start(args) ;
1648 #endif /* !NO_STDARG */
1649
1650 (void) vfprintf(stderr,fmt,args) ;
1651 va_end(args) ;
1652
1653 (void) fputc('\n',stderr) ;
1654 (void) fflush(stderr); /* to ensure log files are current */
1655 derror_count++;
1656 }
1657
1658
1659 void *
emalloc(size_t size)1660 emalloc ( /* check return from malloc */
1661 size_t size)
1662 {
1663 void *p;
1664
1665 p = (void *) malloc (size);
1666 if (p == 0) {
1667 derror ("out of memory\n");
1668 exit(3);
1669 }
1670 return p;
1671 }
1672
1673 void *
ecalloc(size_t size)1674 ecalloc ( /* check return from calloc */
1675 size_t size)
1676 {
1677 void *p;
1678
1679 p = (void *) calloc (size, 1);
1680 if (p == 0) {
1681 derror ("out of memory\n");
1682 exit(3);
1683 }
1684 return p;
1685 }
1686
1687 void *
erealloc(void * ptr,size_t size)1688 erealloc ( /* check return from realloc */
1689 void *ptr,
1690 size_t size) /* if 0, this is really a free */
1691 {
1692 void *p;
1693
1694 p = (void *) realloc (ptr, size);
1695
1696 if (p == 0 && size != 0) {
1697 derror ("out of memory");
1698 exit(3);
1699 }
1700 return p;
1701 }
1702
1703
1704 /*
1705 * For generated Fortran, change 'e' to 'd' in exponent of double precision
1706 * constants.
1707 */
1708 void
expe2d(char * cp)1709 expe2d(
1710 char *cp) /* string containing double constant */
1711 {
1712 char *expchar = strrchr(cp,'e');
1713 if (expchar) {
1714 *expchar = 'd';
1715 }
1716 }
1717
1718
1719
1720 /* Returns non-zero if n is a power of 2, 0 otherwise */
1721 static
1722 int
pow2(int n)1723 pow2(
1724 int n)
1725 {
1726 int m = n;
1727 int p = 1;
1728
1729 while (m > 0) {
1730 m /= 2;
1731 p *= 2;
1732 }
1733 return p == 2*n;
1734 }
1735
1736
1737 /*
1738 * Grow an integer array as necessary.
1739 *
1740 * Assumption: nar never incremented by more than 1 from last call.
1741 *
1742 * Makes sure an array is within a factor of 2 of the size needed.
1743 *
1744 * Make sure *arpp points to enough space to hold nar integers. If not big
1745 * enough, malloc more space, copy over existing stuff, free old. When
1746 * called for first time, *arpp assumed to be uninitialized.
1747 */
1748 void
grow_iarray(int nar,int ** arpp)1749 grow_iarray(
1750 int nar, /* array must be at least this big */
1751 int **arpp) /* address of start of int array */
1752 {
1753 if (nar == 0) {
1754 *arpp = (int *) emalloc(1 * sizeof(int));
1755 return;
1756 }
1757 if (! pow2(nar)) /* return unless nar is a power of two */
1758 return;
1759 *arpp = (int *) erealloc(*arpp, 2 * nar * sizeof(int));
1760 }
1761
1762
1763 /*
1764 * Grow an array of variables as necessary.
1765 *
1766 * Assumption: nar never incremented by more than 1 from last call.
1767 *
1768 * Makes sure array is within a factor of 2 of the size needed.
1769 *
1770 * Make sure *arpp points to enough space to hold nar variables. If not big
1771 * enough, malloc more space, copy over existing stuff, free old. When
1772 * called for first time, *arpp assumed to be uninitialized.
1773 */
1774 void
grow_varray(int nar,struct vars ** arpp)1775 grow_varray(
1776 int nar, /* array must be at least this big */
1777 struct vars **arpp) /* address of start of var array */
1778 {
1779 if (nar == 0) {
1780 *arpp = (struct vars *) emalloc(1 * sizeof(struct vars));
1781 return;
1782 }
1783 if (! pow2(nar)) /* return unless nar is a power of two */
1784 return;
1785 *arpp = (struct vars *) erealloc(*arpp, 2 * nar * sizeof(struct vars));
1786 }
1787
1788
1789 /*
1790 * Grow an array of dimensions as necessary.
1791 *
1792 * Assumption: nar never incremented by more than 1 from last call.
1793 *
1794 * Makes sure array is within a factor of 2 of the size needed.
1795 *
1796 * Make sure *arpp points to enough space to hold nar dimensions. If not big
1797 * enough, malloc more space, copy over existing stuff, free old. When
1798 * called for first time, *arpp assumed to be uninitialized.
1799 */
1800 void
grow_darray(int nar,struct dims ** arpp)1801 grow_darray(
1802 int nar, /* array must be at least this big */
1803 struct dims **arpp) /* address of start of var array */
1804 {
1805 if (nar == 0) {
1806 *arpp = (struct dims *) emalloc(1 * sizeof(struct dims));
1807 return;
1808 }
1809 if (! pow2(nar)) /* return unless nar is a power of two */
1810 return;
1811 *arpp = (struct dims *) erealloc(*arpp, 2 * nar * sizeof(struct dims));
1812 }
1813
1814
1815 /*
1816 * Grow an array of attributes as necessary.
1817 *
1818 * Assumption: nar never incremented by more than 1 from last call.
1819 *
1820 * Makes sure array is within a factor of 2 of the size needed.
1821 *
1822 * Make sure *arpp points to enough space to hold nar attributes. If not big
1823 * enough, malloc more space, copy over existing stuff, free old. When
1824 * called for first time, *arpp assumed to be uninitialized.
1825 */
1826 void
grow_aarray(int nar,struct atts ** arpp)1827 grow_aarray(
1828 int nar, /* array must be at least this big */
1829 struct atts **arpp) /* address of start of var array */
1830 {
1831 if (nar == 0) {
1832 *arpp = (struct atts *) emalloc(1 * sizeof(struct atts));
1833 return;
1834 }
1835 if (! pow2(nar)) /* return unless nar is a power of two */
1836 return;
1837 *arpp = (struct atts *) erealloc(*arpp, 2 * nar * sizeof(struct atts));
1838 }
1839
1840
1841 /*
1842 * Replace special chars in name so it can be used in C and Fortran
1843 * variable names without causing syntax errors. Here we just replace
1844 * each "-" in a name with "_MINUS_", each "." with "_PERIOD_", etc.
1845 * For bytes with high bit set, from UTF-8 encoding of Unicode, just
1846 * replace with "_xHH", where each H is the appropriate hex digit. If
1847 * a name begins with a number N, such as "4LFTX", replace with
1848 * "DIGIT_N_", such as "DIGIT_4_LFTX".
1849 *
1850 * Returned name is malloc'ed, so caller is responsible for freeing it.
1851 */
1852 extern char*
decodify(const char * name)1853 decodify (
1854 const char *name)
1855 {
1856 int count; /* number chars in newname */
1857 char *newname;
1858 const char *cp;
1859 char *sp;
1860 static int init = 0;
1861 static char* repls[256]; /* replacement string for each char */
1862 static int lens[256]; /* lengths of replacement strings */
1863 static struct {
1864 char c;
1865 char *s;
1866 } ctable[] = {
1867 {' ', "_SPACE_"},
1868 {'!', "_EXCLAMATION_"},
1869 {'"', "_QUOTATION_"},
1870 {'#', "_HASH_"},
1871 {'$', "_DOLLAR_"},
1872 {'%', "_PERCENT_"},
1873 {'&', "_AMPERSAND_"},
1874 {'\'', "_APOSTROPHE_"},
1875 {'(', "_LEFTPAREN_"},
1876 {')', "_RIGHTPAREN_"},
1877 {'*', "_ASTERISK_"},
1878 {'+', "_PLUS_"},
1879 {',', "_COMMA_"},
1880 {'-', "_MINUS_"},
1881 {'.', "_PERIOD_"},
1882 {':', "_COLON_"},
1883 {';', "_SEMICOLON_"},
1884 {'<', "_LESSTHAN_"},
1885 {'=', "_EQUALS_"},
1886 {'>', "_GREATERTHAN_"},
1887 {'?', "_QUESTION_"},
1888 {'@', "_ATSIGN_"},
1889 {'[', "_LEFTBRACKET_"},
1890 {'\\', "_BACKSLASH_"},
1891 {']', "_RIGHTBRACKET_"},
1892 {'^', "_CIRCUMFLEX_"},
1893 {'`', "_BACKQUOTE_"},
1894 {'{', "_LEFTCURLY_"},
1895 {'|', "_VERTICALBAR_"},
1896 {'}', "_RIGHTCURLY_"},
1897 {'~', "_TILDE_"},
1898 {'/', "_SLASH_"} /* should not occur in names */
1899 /* {'_', "_UNDERSCORE_"} */
1900 };
1901 static int idtlen;
1902 static int hexlen;
1903 int nctable = (sizeof(ctable))/(sizeof(ctable[0]));
1904 int newlen;
1905
1906 idtlen = strlen("DIGIT_n_"); /* initial digit template */
1907 hexlen = 1+strlen("_XHH"); /* template for hex of non-ASCII bytes */
1908 if(init == 0) {
1909 int i;
1910 char *rp;
1911
1912 for(i = 0; i < 128; i++) {
1913 rp = emalloc(2);
1914 rp[0] = i;
1915 rp[1] = '\0';
1916 repls[i] = rp;
1917 }
1918 for(i=0; i < nctable; i++) {
1919 size_t j = ctable[i].c;
1920 free(repls[j]);
1921 repls[j] = ctable[i].s;
1922 }
1923 for(i = 128; i < 256; i++) {
1924 rp = emalloc(hexlen);
1925 snprintf(rp, hexlen, "_X%2.2X", i);
1926 rp[hexlen - 1] = '\0';
1927 repls[i] = rp;
1928 }
1929 for(i = 0; i < 256; i++) {
1930 lens[i] = strlen(repls[i]);
1931 }
1932 init = 1; /* only do this initialization once */
1933 }
1934
1935 count = 0;
1936 cp = name;
1937 while(*cp != '\0') { /* get number of extra bytes for newname */
1938 size_t j;
1939 if(*cp < 0) { /* handle signed or unsigned chars */
1940 j = *cp + 256;
1941 } else {
1942 j = *cp;
1943 }
1944 count += lens[j] - 1;
1945 cp++;
1946 }
1947
1948 cp = name;
1949 if('0' <= *cp && *cp <= '9') { /* names that begin with a digit */
1950 count += idtlen - 1;
1951 }
1952 newlen = strlen(name) + count + 1; /* bytes left to be filled */
1953 newname = (char *) emalloc(newlen);
1954 sp = newname;
1955 if('0' <= *cp && *cp <= '9') { /* handle initial digit, if any */
1956 snprintf(sp, newlen, "DIGIT_%c_", *cp);
1957 sp += idtlen;
1958 newlen -= idtlen;
1959 cp++;
1960 }
1961 *sp = '\0';
1962 while(*cp != '\0') { /* copy name to newname, replacing special chars */
1963 size_t j, len;
1964 /* cp is current position in name, sp is current position in newname */
1965 if(*cp < 0) { /* j is table index for character *cp */
1966 j = *cp + 256;
1967 } else {
1968 j = *cp;
1969 }
1970 len = strlcat(sp, repls[j], newlen);
1971 assert(len < newlen);
1972 sp += lens[j];
1973 newlen -= lens[j];
1974 cp++;
1975 }
1976 return newname;
1977 }
1978
1979
1980 /*
1981 * Replace escaped chars in CDL representation of name such as
1982 * 'abc\:def\ gh\\i' with unescaped version, such as 'abc:def gh\i'.
1983 */
1984 void
deescapify(char * name)1985 deescapify (char *name)
1986 {
1987 const char *cp = name;
1988 char *sp;
1989 size_t len = strlen(name);
1990 char *newname;
1991
1992 if(strchr(name, '\\') == NULL)
1993 return;
1994
1995 newname = (char *) emalloc(len + 1);
1996 cp = name;
1997 sp = newname;
1998 while(*cp != '\0') { /* delete '\' chars, except change '\\' to '\' */
1999 switch (*cp) {
2000 case '\\':
2001 if(*(cp+1) == '\\') {
2002 *sp++ = '\\';
2003 cp++;
2004 }
2005 break;
2006 default:
2007 *sp++ = *cp;
2008 break;
2009 }
2010 cp++;
2011 }
2012 *sp = '\0';
2013 /* assert(strlen(newname) <= strlen(name)); */
2014 strncpy(name, newname, len);
2015 free(newname);
2016 return;
2017 }
2018