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
24extern char *netcdf_name; /* output netCDF filename, if on command line. */
25extern int netcdf_flag;
26extern int c_flag;
27extern int fortran_flag;
28extern int cmode_modifier;
29extern int nofill_flag;
30
31int lineno = 1;
32int derror_count = 0;
33
34
35/* create netCDF from in-memory structure */
36static void
37gen_netcdf(
38     char *filename) /* name for output netcdf file */
39{
40    int idimivariatt;
41    int dimid;
42    int varid;
43    int stat;
44
45    stat = nc_create(filenamecmode_modifier, &ncid);
46    check_err(stat);
47
48    /* define dimensions from info in dims array */
49    for (idim = 0; idim < ndimsidim++) {
50 stat = nc_def_dim(nciddims[idim].namedims[idim].size, &dimid);
51 check_err(stat);
52    }
53
54    /* define variables from info in vars array */
55    for (ivar = 0; ivar < nvarsivar++) {
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 < nattsiatt++) {
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(ncidvaridatts[iatt].name,
71     atts[iatt].typeatts[iatt].len,
72     (signed char *) atts[iatt].val);
73     break;
74 case NC_CHAR:
75     stat = nc_put_att_text(ncidvaridatts[iatt].name,
76    atts[iatt].len,
77    (char *) atts[iatt].val);
78     break;
79 case NC_SHORT:
80     stat = nc_put_att_short(ncidvaridatts[iatt].name,
81     atts[iatt].typeatts[iatt].len,
82     (short *) atts[iatt].val);
83     break;
84 case NC_INT:
85     stat = nc_put_att_int(ncidvaridatts[iatt].name,
86     atts[iatt].typeatts[iatt].len,
87     (int *) atts[iatt].val);
88     break;
89 case NC_FLOAT:
90     stat = nc_put_att_float(ncidvaridatts[iatt].name,
91     atts[iatt].typeatts[iatt].len,
92     (float *) atts[iatt].val);
93     break;
94 case NC_DOUBLE:
95     stat = nc_put_att_double(ncidvaridatts[iatt].name,
96     atts[iatt].typeatts[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(ncidNC_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 */
120static char *
121cstring(
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, *spch;
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 */
205static void
206gen_c(
207     const char *filename)
208{
209    int idimivariattjattmaxdims;
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 < ndimsidim++) {
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 < ndimsidim++) {
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 < nvarsivar++)
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 < nvarsivar++) {
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 < nvarsivar++) {
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 < nvarsivar++) {
283 if (vars[ivar].ndims > 0) {
284     sprintf(stmnt, "   int %s_dims[RANK_%s];",
285     vars[ivar].lnamevars[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 < nattsiatt++) {
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 < nattsiatt++) {
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 < ndimsidim++) {
350 sprintf(stmnt,
351 "   stat = nc_def_dim(ncid, \"%s\", %s_len, &%s_dim);",
352 dims[idim].namedims[idim].lnamedims[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 < nvarsivar++) {
362     cline("");
363     for (idim = 0; idim < vars[ivar].ndimsidim++) {
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 < nattsiatt++) {
397     if (atts[iatt].type == NC_CHAR) { /* string */
398 val_string = cstrstr((char *) atts[iatt].valatts[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 */
451static const char *
452ncftype(
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 */
487const char *
488nfstype(
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 */
515const char *
516nfftype(
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 */
546static const char *
547ftypename(
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 */
573static void
574gen_fortran(
575     const char *filename)
576{
577    int idimivariattjattitypemaxdims;
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 < ndimsidim++) {
613     sprintf(stmnt, "integer  %s_dim", dims[idim].lname);
614     fline(stmnt);
615 }
616
617 fline("* dimension lengths");
618 for (idim = 0; idim < ndimsidim++) {
619     sprintf(stmnt, "integer  %s_len", dims[idim].lname);
620     fline(stmnt);
621 }
622 for (idim = 0; idim < ndimsidim++) {
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 < nvarsivar++)
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 < nvarsivar++) {
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 < nvarsivar++) {
650     sprintf(stmnt, "integer  %s_rank", vars[ivar].lname);
651     fline(stmnt);
652 }
653 for (ivar = 0; ivar < nvarsivar++) {
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 < nvarsivar++) {
661     if (vars[ivar].ndims > 0) {
662 sprintf(stmnt, "integer  %s_dims(%s_rank)",
663 vars[ivar].lnamevars[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 < nvarsivar++) {
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(stmnts2);
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 < ntypesitype++)
709        max_atts[(int)types[itype]] = 0;
710
711    vector_atts = 0;
712    for (iatt = 0; iatt < nattsiatt++) {
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 < ntypesitype++) {
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 < ndimsidim++) {
752 if (dims[idim].size == NC_UNLIMITED)
753            sprintf(stmnt, "iret = nf_def_dim(ncid, \'%s\', NF_UNLIMITED, %s_dim)",
754                    dims[idim].namedims[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 < nvarsivar++) {
767     for (idim = 0; idim < vars[ivar].ndimsidim++) {
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 < nattsiatt++) {
799     if (atts[iatt].type == NC_CHAR) { /* string */
800 val_string = fstrstr((char *) atts[iatt].valatts[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 */
852void
853cline(
854     const char *stmnt)
855{
856    FILE *cout = stdout;
857
858    fputs(stmntcout);
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 */
868void
869fline(
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(stmntfout);
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 */
899const char *
900nctype(
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 */
926const char *
927ncctype(
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 */
954const char *
955ncstype(
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 */
981const char *
982ncatype(
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 */
1006size_t
1007nctypesize(
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 */
1037char *
1038fstring(
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 */
1093char *
1094cstrstr(
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 < lenii++) {
1116 istr[ii] = valp[ii];
1117    }
1118    istr[len] = '\0';
1119
1120    *cp++ = '"';
1121    for(ii = 0; ii < lenii++) {
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.  */
1162char *
1163fstrstr(
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 *cptstr[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 < ilenii++) {
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(cptstr);
1211 cp += strlen(tstr);
1212 was_print = 0;
1213    }
1214    istr++;
1215
1216    for(ii = 1; ii < ilenii++) { /* 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(cptstr);
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
1257static void
1258cl_netcdf(void)
1259{
1260    int stat = nc_close(ncid);
1261    check_err(stat);
1262}
1263
1264
1265static void
1266cl_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 ... */
1281static int
1282used_in_rec_var(
1283    int idim /* id of dimension */
1284    ) {
1285    int ivar;
1286
1287    for (ivar = 0; ivar < nvarsivar++) {
1288 if (vars[ivar].ndims > 0 && vars[ivar].dims[0] == rec_dim) {
1289     int jdim;
1290     for (jdim = 0; jdim < vars[ivar].ndimsjdim++) {
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 */
1301static const char *
1302f_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 */
1327static void
1328cl_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 < nvarsivar++) {
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 < nvarsivar++) {
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(stmnts2);
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 < nvarsivar++) {
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(stmnts2);
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 < nvarsivar++) {
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 < ndimsidim++) {
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 < nvarsivar++) {
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 < nvarsivar++) {
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 < nvarsivar++) {
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->lnamev->lnamev->lnamev->lname);
1449 fline(stmnt);
1450     }
1451 }
1452
1453 fline(" ");
1454 fline("* data variables");
1455
1456        for (ivar = 0; ivar < nvarsivar++) {
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(stmnts2);
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 < nvarsivar++) {
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->ndimsidim++) {
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 < nvarsivar++) {
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->ndimsidim++) {
1528     sprintf(stmnt, "%s_start(%d) = 1", v->lnameidim+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 - idimdims[v->dims[idim]].lname);
1534     fline(stmnt);
1535 }
1536                sprintf(stmnt, "%s_count(%d) = %s_nr", v->lname,
1537                        v->ndimsv->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->lnamev->lnamev->lnamev->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->lnamev->lnamev->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. */
1576void
1577define_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
1602void
1603close_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
1614void
1615check_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
1626void
1627derror(const char *fmt, ...)
1628#else
1629/*VARARGS1*/
1630void
1631derror(fmtva_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: ", prognamecdlname);
1641    else
1642      (void) fprintf(stderr,"%s: %s line %d: ", prognamecdlnamelineno);
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
1659void *
1660emalloc ( /* 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
1673void *
1674ecalloc ( /* 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
1687void *
1688erealloc ( /* 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 (ptrsize);
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 */
1708void
1709expe2d(
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 */
1721static
1722int
1723pow2(
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 */
1748void
1749grow_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 */
1774void
1775grow_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 */
1800void
1801grow_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 */
1826void
1827grow_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#ifndef HAVE_STRLCAT
1841/* $OpenBSD: strlcat.c,v 1.12 2005/03/30 20:13:52 otto Exp $ */
1842
1843/*
1844 * Copyright (c) 1998 Todd C. Miller <Todd.Miller@courtesan.com>
1845 *
1846 * Permission to use, copy, modify, and distribute this software for any
1847 * purpose with or without fee is hereby granted, provided that the above
1848 * copyright notice and this permission notice appear in all copies.
1849 *
1850 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
1851 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
1852 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
1853 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
1854 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
1855 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
1856 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
1857 */
1858
1859/*
1860 * Appends src to string dst of size siz (unlike strncat, siz is the
1861 * full size of dst, not space left).  At most siz-1 characters
1862 * will be copied.  Always NUL terminates (unless siz <= strlen(dst)).
1863 * Returns strlen(src) + MIN(siz, strlen(initial dst)).
1864 * If retval >= siz, truncation occurred.
1865 */
1866size_t
1867strlcat(char *dst, const char *src, size_t siz)
1868{
1869 char *d = dst;
1870 const char *s = src;
1871 size_t n = siz;
1872 size_t dlen;
1873
1874 /* Find the end of dst and adjust bytes left but don't go past end */
1875 while (n-- != 0 && *d != '\0')
1876 d++;
1877 dlen = d - dst;
1878 n = siz - dlen;
1879
1880 if (n == 0)
1881 return(dlen + strlen(s));
1882 while (*s != '\0') {
1883 if (n != 1) {
1884 *d++ = *s;
1885 n--;
1886 }
1887 s++;
1888 }
1889 *d = '\0';
1890
1891 return(dlen + (s - src)); /* count does not include NUL */
1892}
1893#endif /* ! HAVE_STRLCAT */
1894
1895
1896/*
1897 * Replace special chars in name so it can be used in C and Fortran
1898 * variable names without causing syntax errors.  Here we just replace
1899 * each "-" in a name with "_MINUS_", each "." with "_PERIOD_", etc.
1900 * For bytes with high bit set, from UTF-8 encoding of Unicode, just
1901 * replace with "_xHH", where each H is the appropriate hex digit.  If
1902 * a name begins with a number N, such as "4LFTX", replace with
1903 * "DIGIT_N_", such as "DIGIT_4_LFTX".
1904 *
1905 * Returned name is malloc'ed, so caller is responsible for freeing it.
1906 */
1907extern char*
1908decodify (
1909    const char *name)
1910{
1911    int count; /* number chars in newname */
1912    char *newname;
1913    const char *cp;
1914    char *sp;
1915    static int init = 0;
1916    static char* repls[256]; /* replacement string for each char */
1917    static int lens[256]; /* lengths of replacement strings */
1918    static struct {
1919 char c;
1920 char *s;
1921    } ctable[] = {
1922 {' ', "_SPACE_"},
1923 {'!', "_EXCLAMATION_"},
1924 {'"', "_QUOTATION_"},
1925 {'#', "_HASH_"},
1926 {'$', "_DOLLAR_"},
1927 {'%', "_PERCENT_"},
1928 {'&', "_AMPERSAND_"},
1929 {'\'', "_APOSTROPHE_"},
1930 {'(', "_LEFTPAREN_"},
1931 {')', "_RIGHTPAREN_"},
1932 {'*', "_ASTERISK_"},
1933 {'+', "_PLUS_"},
1934 {',', "_COMMA_"},
1935 {'-', "_MINUS_"},
1936 {'.', "_PERIOD_"},
1937 {':', "_COLON_"},
1938 {';', "_SEMICOLON_"},
1939 {'<', "_LESSTHAN_"},
1940 {'=', "_EQUALS_"},
1941 {'>', "_GREATERTHAN_"},
1942 {'?', "_QUESTION_"},
1943 {'@', "_ATSIGN_"},
1944 {'[', "_LEFTBRACKET_"},
1945 {'\\', "_BACKSLASH_"},
1946 {']', "_RIGHTBRACKET_"},
1947 {'^', "_CIRCUMFLEX_"},
1948 {'`', "_BACKQUOTE_"},
1949 {'{', "_LEFTCURLY_"},
1950 {'|', "_VERTICALBAR_"},
1951 {'}', "_RIGHTCURLY_"},
1952 {'~', "_TILDE_"},
1953  {'/', "_SLASH_"}  /* should not occur in names */
1954/*  {'_', "_UNDERSCORE_"} */
1955    };
1956    static int idtlen;
1957    static int hexlen;
1958    int nctable = (sizeof(ctable))/(sizeof(ctable[0]));
1959    int newlen;
1960
1961    idtlen = strlen("DIGIT_n_"); /* initial digit template */
1962    hexlen = 1+strlen("_XHH"); /* template for hex of non-ASCII bytes */
1963    if(init == 0) {
1964 int i;
1965 char *rp;
1966
1967 for(i = 0; i < 128; i++) {
1968     rp = emalloc(2);
1969     rp[0] = i;
1970     rp[1] = '\0';
1971     repls[i] = rp;
1972 }
1973 for(i=0; i < nctablei++) {
1974     size_t j = ctable[i].c;
1975     free(repls[j]);
1976     repls[j] = ctable[i].s;
1977 }
1978 for(i = 128; i < 256; i++) {
1979     rp = emalloc(hexlen);
1980     snprintf(rphexlen, "_X%2.2X", i);
1981     rp[hexlen - 1] = '\0';
1982     repls[i] = rp;
1983 }
1984 for(i = 0; i < 256; i++) {
1985     lens[i] = strlen(repls[i]);
1986 }
1987 init = 1; /* only do this initialization once */
1988    }
1989
1990    count = 0;
1991    cp = name;
1992    while(*cp != '\0') { /* get number of extra bytes for newname */
1993 size_t j;
1994        if(*cp < 0) { /* handle signed or unsigned chars */
1995     j = *cp + 256;
1996 } else {
1997     j = *cp;
1998 }
1999  count += lens[j] - 1;
2000 cp++;
2001    }
2002
2003    cp = name;
2004    if('0' <= *cp && *cp <= '9') { /* names that begin with a digit */
2005 count += idtlen - 1;
2006    }
2007    newlen = strlen(name) + count + 1; /* bytes left to be filled */
2008    newname = (char *) emalloc(newlen);
2009    sp = newname;
2010    if('0' <= *cp && *cp <= '9') { /* handle initial digit, if any */
2011 snprintf(spnewlen, "DIGIT_%c_", *cp);
2012 sp += idtlen;
2013 newlen -= idtlen;
2014 cp++;
2015    }
2016    *sp = '\0';
2017    while(*cp != '\0') { /* copy name to newname, replacing special chars */
2018 size_t jlen;
2019 /* cp is current position in name, sp is current position in newname */
2020        if(*cp < 0) {       /* j is table index for character *cp */
2021     j = *cp + 256;
2022 } else {
2023     j = *cp;
2024 }
2025 len = strlcat(sprepls[j], newlen);
2026 assert(len < newlen);
2027 sp += lens[j];
2028 newlen -= lens[j];
2029 cp++;
2030    }
2031    return newname;
2032}
2033
2034
2035/*
2036 * Replace escaped chars in CDL representation of name such as
2037 * 'abc\:def\ gh\\i' with unescaped version, such as 'abc:def gh\i'.
2038 */
2039void
2040deescapify (char *name)
2041{
2042    const char *cp = name;
2043    char *sp;
2044    size_t len = strlen(name);
2045    char *newname;
2046
2047    if(strchr(name, '\\') == NULL)
2048 return;
2049
2050    newname = (char *) emalloc(len + 1);
2051    cp = name;
2052    sp = newname;
2053    while(*cp != '\0') { /* delete '\' chars, except change '\\' to '\' */
2054 switch (*cp) {
2055 case '\\':
2056     if(*(cp+1) == '\\') {
2057 *sp++ = '\\';
2058 cp++;
2059     }
2060     break;
2061 default:
2062     *sp++ = *cp;
2063     break;
2064 }
2065 cp++;
2066    }
2067    *sp = '\0';
2068    /* assert(strlen(newname) <= strlen(name)); */
2069    strncpy(namenewnamelen);
2070    free(newname);
2071    return;
2072}


HyperKWIC - Version 7.20DA executed at 11:37 on 27 Oct 2017 | Polyhedron Solutions - INTERNAL USE | COMMERCIAL (Any O/S) SN 4AKIed