/* make Fortran to put record */
static void
gen_load_fortran(
void *rec_start
)
{
char stmnt[FORT_MAX_STMNT];
struct vars *v = &vars[varnum];
if (!v->has_data)
return;
if (v->ndims == 0 || v->dims[0] != rec_dim) {
sprintf(stmnt, "* store %s", v->name);
fline(stmnt);
}
/* generate code to initialize variable with values found in CDL input */
if (v->type != NC_CHAR) {
f_var_init(varnum, rec_start);
} else {
v->data_stmnt = fstrstr(rec_start, valnum);
}
if (v->ndims >0 && v->dims[0] == rec_dim) {
return;
}
if (v->type != NC_CHAR) {
sprintf(stmnt, "iret = nf_put_var_%s(ncid, %s_id, %s)",
nfftype(v->type), v->lname, v->lname);
} else {
char *char_expr = fstrstr(rec_start, valnum);
if(strlen("iret = nf_put_var_(ncid, _id, )") +
strlen(nfftype(v->type)) +
strlen(v->lname) +
strlen(char_expr) > FORT_MAX_STMNT) {
derror("FORTRAN statement to assign values to %s too long!",
v->lname);
exit(9);
}
sprintf(stmnt, "iret = nf_put_var_%s(ncid, %s_id, %s)",
nfftype(v->type), v->lname, char_expr);
free(char_expr);
}
fline(stmnt);
fline("call check_err(iret)");
}
/* make Fortran to put record */
static void
gen_load_fortran(
void *rec_start
)
{
char stmnt[FORT_MAX_STMNT];
struct vars *v = &vars[varnum];
if (!v->has_data)
return;
if (v->ndims == 0 || v->dims[0] != rec_dim) {
sprintf(stmnt, "* store %s", v->name);
fline(stmnt);
}
/* generate code to initialize variable with values found in CDL input */
if (v->type != NC_CHAR) {
f_var_init(varnum, (char*)rec_start);
} else {
v->data_stmnt = (char*) fstrstr((char*)rec_start, valnum);
}
if (v->ndims >0 && v->dims[0] == rec_dim) {
return;
}
if (v->type != NC_CHAR) {
sprintf(stmnt, "iret = nf_put_var_%s(ncid, %s_id, %s)",
nfftype(v->type), v->lname, v->lname);
} else {
char *char_expr = (char*) fstrstr((char*)rec_start, valnum);
sprintf(stmnt, "iret = nf_put_var_%s(ncid, %s_id, %s)",
nfftype(v->type), v->lname, char_expr);
free(char_expr);
}
fline(stmnt);
fline("call check_err(iret)");
}
/*
* Generate FORTRAN code for creating netCDF from in-memory structure.
*/
static void
gen_fortran(
const char *filename)
{
int idim, ivar, iatt, jatt, itype, maxdims;
int vector_atts;
char *val_string;
char stmnt[FORT_MAX_STMNT];
char s2[NC_MAX_NAME + 10];
char *sp;
/* Need how many netCDF types there are, because we create an array
* for each type of attribute. */
int ntypes = 6; /* number of netCDF types, NC_BYTE, ... */
nc_type types[6]; /* at least ntypes */
size_t max_atts[NC_DOUBLE + 1];
types[0] = NC_BYTE;
types[1] = NC_CHAR;
types[2] = NC_SHORT;
types[3] = NC_INT;
types[4] = NC_FLOAT;
types[5] = NC_DOUBLE;
fline("program fgennc");
fline("include 'netcdf.inc'");
/* create necessary declarations */
fline("* error status return");
fline("integer iret");
fline("* netCDF id");
fline("integer ncid");
if (nofill_flag) {
fline("* to save old fill mode before changing it temporarily");
fline("integer oldmode");
}
if (ndims > 0) {
fline("* dimension ids");
for (idim = 0; idim < ndims; idim++) {
sprintf(stmnt, "integer %s_dim", dims[idim].lname);
fline(stmnt);
}
fline("* dimension lengths");
for (idim = 0; idim < ndims; idim++) {
sprintf(stmnt, "integer %s_len", dims[idim].lname);
fline(stmnt);
}
for (idim = 0; idim < ndims; idim++) {
if (dims[idim].size == NC_UNLIMITED) {
sprintf(stmnt, "parameter (%s_len = NF_UNLIMITED)",
dims[idim].lname);
} else {
sprintf(stmnt, "parameter (%s_len = %lu)",
dims[idim].lname,
(unsigned long) dims[idim].size);
}
fline(stmnt);
}
}
maxdims = 0; /* most dimensions of any variable */
for (ivar = 0; ivar < nvars; ivar++)
if (vars[ivar].ndims > maxdims)
maxdims = vars[ivar].ndims;
if (nvars > 0) {
fline("* variable ids");
for (ivar = 0; ivar < nvars; ivar++) {
sprintf(stmnt, "integer %s_id", vars[ivar].lname);
fline(stmnt);
}
fline("* rank (number of dimensions) for each variable");
for (ivar = 0; ivar < nvars; ivar++) {
sprintf(stmnt, "integer %s_rank", vars[ivar].lname);
fline(stmnt);
}
for (ivar = 0; ivar < nvars; ivar++) {
sprintf(stmnt, "parameter (%s_rank = %d)", vars[ivar].lname,
vars[ivar].ndims);
fline(stmnt);
}
fline("* variable shapes");
for (ivar = 0; ivar < nvars; ivar++) {
if (vars[ivar].ndims > 0) {
sprintf(stmnt, "integer %s_dims(%s_rank)",
vars[ivar].lname, vars[ivar].lname);
fline(stmnt);
}
}
}
/* declarations for variables to be initialized */
if (nvars > 0) { /* we have variables */
fline("* data variables");
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
/* Generate declarations here for non-record data variables only.
Record variables are declared in separate subroutine later,
when we know how big they are. */
if (v->ndims > 0 && v->dims[0] == rec_dim) {
continue;
}
/* Make declarations for non-text variables only;
for text variables, just include string in nf_put_var call */
if (v->type == NC_CHAR) {
continue;
}
if (v->ndims == 0) { /* scalar */
sprintf(stmnt, "%s %s", ncftype(v->type),
v->lname);
} else {
sprintf(stmnt, "%s %s(", ncftype(v->type),
v->lname);
/* reverse dimensions for FORTRAN */
for (idim = v->ndims-1; idim >= 0; idim--) {
sprintf(s2, "%s_len, ",
dims[v->dims[idim]].lname);
strcat(stmnt, s2);
}
sp = strrchr(stmnt, ',');
if(sp != NULL) {
*sp = '\0';
}
strcat(stmnt, ")");
}
fline(stmnt);
}
}
/* determine what attribute vectors needed */
for (itype = 0; itype < ntypes; itype++)
max_atts[(int)types[itype]] = 0;
vector_atts = 0;
for (iatt = 0; iatt < natts; iatt++) {
if (atts[iatt].len > max_atts[(int) atts[iatt].type]) {
max_atts[(int)atts[iatt].type] = atts[iatt].len;
vector_atts = 1;
}
}
if (vector_atts) {
fline("* attribute vectors");
for (itype = 0; itype < ntypes; itype++) {
if (types[itype] != NC_CHAR && max_atts[(int)types[itype]] > 0) {
sprintf(stmnt, "%s %sval(%lu)", ncftype(types[itype]),
nfstype(types[itype]),
(unsigned long) max_atts[(int)types[itype]]);
fline(stmnt);
}
}
}
/* create netCDF file, uses NC_CLOBBER mode */
fline("* enter define mode");
if (!cmode_modifier) {
sprintf(stmnt, "iret = nf_create(\'%s\', NF_CLOBBER, ncid)", filename);
} else if (cmode_modifier & NC_64BIT_OFFSET) {
sprintf(stmnt, "iret = nf_create(\'%s\', OR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)", filename);
#ifdef USE_NETCDF4
} else if (cmode_modifier & NC_CLASSIC_MODEL) {
sprintf(stmnt, "iret = nf_create(\'%s\', OR(NF_CLOBBER,NC_NETCDF4,NC_CLASSIC_MODEL), ncid)", filename);
} else if (cmode_modifier & NC_NETCDF4) {
sprintf(stmnt, "iret = nf_create(\'%s\', OR(NF_CLOBBER,NF_NETCDF4), ncid)", filename);
#endif
} else {
derror("unknown cmode modifier");
}
fline(stmnt);
fline("call check_err(iret)");
/* define dimensions from info in dims array */
if (ndims > 0)
fline("* define dimensions");
for (idim = 0; idim < ndims; idim++) {
if (dims[idim].size == NC_UNLIMITED)
sprintf(stmnt, "iret = nf_def_dim(ncid, \'%s\', NF_UNLIMITED, %s_dim)",
dims[idim].name, dims[idim].lname);
else
sprintf(stmnt, "iret = nf_def_dim(ncid, \'%s\', %lu, %s_dim)",
dims[idim].name, (unsigned long) dims[idim].size,
dims[idim].lname);
fline(stmnt);
fline("call check_err(iret)");
}
/* define variables from info in vars array */
if (nvars > 0) {
fline("* define variables");
for (ivar = 0; ivar < nvars; ivar++) {
for (idim = 0; idim < vars[ivar].ndims; idim++) {
sprintf(stmnt, "%s_dims(%d) = %s_dim",
vars[ivar].lname,
vars[ivar].ndims - idim, /* reverse dimensions */
dims[vars[ivar].dims[idim]].lname);
fline(stmnt);
}
if (vars[ivar].ndims > 0) { /* a dimensioned variable */
sprintf(stmnt,
"iret = nf_def_var(ncid, \'%s\', %s, %s_rank, %s_dims, %s_id)",
vars[ivar].name,
ftypename(vars[ivar].type),
vars[ivar].lname,
vars[ivar].lname,
vars[ivar].lname);
} else { /* a scalar */
sprintf(stmnt,
"iret = nf_def_var(ncid, \'%s\', %s, %s_rank, 0, %s_id)",
vars[ivar].name,
ftypename(vars[ivar].type),
vars[ivar].lname,
vars[ivar].lname);
}
fline(stmnt);
fline("call check_err(iret)");
}
}
/* define attributes from info in atts array */
if (natts > 0) {
fline("* assign attributes");
for (iatt = 0; iatt < natts; iatt++) {
if (atts[iatt].type == NC_CHAR) { /* string */
val_string = fstrstr((char *) atts[iatt].val, atts[iatt].len);
sprintf(stmnt,
"iret = nf_put_att_text(ncid, %s%s, \'%s\', %lu, %s)",
atts[iatt].var == -1 ? "NF_GLOBAL" : vars[atts[iatt].var].lname,
atts[iatt].var == -1 ? "" : "_id",
atts[iatt].name,
(unsigned long) atts[iatt].len,
val_string);
fline(stmnt);
fline("call check_err(iret)");
free(val_string);
} else {
for (jatt = 0; jatt < atts[iatt].len ; jatt++) {
val_string = fstring(atts[iatt].type,atts[iatt].val,jatt);
sprintf(stmnt, "%sval(%d) = %s",
nfstype(atts[iatt].type),
jatt+1,
val_string);
fline(stmnt);
free (val_string);
}
sprintf(stmnt,
"iret = nf_put_att_%s(ncid, %s%s, \'%s\', %s, %lu, %sval)",
nfftype(atts[iatt].type),
atts[iatt].var == -1 ? "NCGLOBAL" : vars[atts[iatt].var].lname,
atts[iatt].var == -1 ? "" : "_id",
atts[iatt].name,
ftypename(atts[iatt].type),
(unsigned long) atts[iatt].len,
nfstype(atts[iatt].type));
fline(stmnt);
fline("call check_err(iret)");
}
}
}
if (nofill_flag) {
fline("* don't initialize variables with fill values");
fline("iret = nf_set_fill(ncid, NF_NOFILL, oldmode)");
fline("call check_err(iret)");
}
fline("* leave define mode");
fline("iret = nf_enddef(ncid)");
fline("call check_err(iret)");
}
/* Generate Fortran for cleaning up and closing file */
static void
cl_fortran(void)
{
int ivar;
int idim;
char stmnt[FORT_MAX_STMNT];
char s2[FORT_MAX_STMNT];
char*sp;
int have_rec_var = 0;
/* do we have any record variables? */
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
if (v->ndims > 0 && v->dims[0] == rec_dim) {
have_rec_var = 1;
break;
}
}
if (have_rec_var) {
fline(" ");
fline("* Write record variables");
sprintf(stmnt, "call writerecs(ncid,");
/* generate parameter list for subroutine to write record vars */
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
/* if a record variable, include id in parameter list */
if (v->ndims > 0 && v->dims[0] == rec_dim) {
sprintf(s2, "%s_id,", v->lname);
strcat(stmnt, s2);
}
}
sp = strrchr(stmnt, ',');
if(sp != NULL) {
*sp = '\0';
}
strcat(stmnt, ")");
fline(stmnt);
}
fline(" ");
fline("iret = nf_close(ncid)");
fline("call check_err(iret)");
fline("end");
fline(" ");
if (have_rec_var) {
sprintf(stmnt, "subroutine writerecs(ncid,");
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
if (v->ndims > 0 && v->dims[0] == rec_dim) {
sprintf(s2, "%s_id,", v->lname);
strcat(stmnt, s2);
}
}
sp = strrchr(stmnt, ',');
if(sp != NULL) {
*sp = '\0';
}
strcat(stmnt, ")");
fline(stmnt);
fline(" ");
fline("* netCDF id");
fline("integer ncid");
fline("* variable ids");
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
if (v->ndims > 0 && v->dims[0] == rec_dim) {
sprintf(stmnt, "integer %s_id", v->lname);
fline(stmnt);
}
}
fline(" ");
fline("include 'netcdf.inc'");
/* create necessary declarations */
fline("* error status return");
fline("integer iret");
/* generate integer/parameter declarations for all dimensions
used in record variables, except record dimension. */
fline(" ");
fline("* netCDF dimension sizes for dimensions used with record variables");
for (idim = 0; idim < ndims; idim++) {
/* if used in a record variable and not record dimension */
if (used_in_rec_var(idim) && dims[idim].size != NC_UNLIMITED) {
sprintf(stmnt, "integer %s_len", dims[idim].lname);
fline(stmnt);
sprintf(stmnt, "parameter (%s_len = %lu)",
dims[idim].lname, (unsigned long) dims[idim].size);
fline(stmnt);
}
}
fline(" ");
fline("* rank (number of dimensions) for each variable");
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
if (v->ndims > 0 && v->dims[0] == rec_dim) {
sprintf(stmnt, "integer %s_rank", v->lname);
fline(stmnt);
}
}
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
if (v->ndims > 0 && v->dims[0] == rec_dim) {
sprintf(stmnt, "parameter (%s_rank = %d)", v->lname,
v->ndims);
fline(stmnt);
}
}
fline("* starts and counts for array sections of record variables");
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
if (v->ndims > 0 && v->dims[0] == rec_dim) {
sprintf(stmnt,
"integer %s_start(%s_rank), %s_count(%s_rank)",
v->lname, v->lname, v->lname, v->lname);
fline(stmnt);
}
}
fline(" ");
fline("* data variables");
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
if (v->ndims > 0 && v->dims[0] == rec_dim) {
char *sp;
fline(" ");
sprintf(stmnt, "integer %s_nr", v->lname);
fline(stmnt);
if (v->nrecs > 0) {
sprintf(stmnt, "parameter (%s_nr = %lu)",
v->lname, (unsigned long) v->nrecs);
} else {
sprintf(stmnt, "parameter (%s_nr = 1)",
v->lname);
}
fline(stmnt);
if (v->type != NC_CHAR) {
sprintf(stmnt, "%s %s(", ncftype(v->type),
v->lname);
/* reverse dimensions for FORTRAN */
for (idim = v->ndims-1; idim >= 0; idim--) {
if(v->dims[idim] == rec_dim) {
sprintf(s2, "%s_nr, ", v->lname);
} else {
sprintf(s2, "%s_len, ",
dims[v->dims[idim]].lname);
}
strcat(stmnt, s2);
}
sp = strrchr(stmnt, ',');
if(sp != NULL) {
*sp = '\0';
}
strcat(stmnt, ")");
fline(stmnt);
}
}
}
fline(" ");
/* Emit DATA statements after declarations, because f2c on Linux can't
handle interspersing them */
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
if (v->ndims > 0 && v->dims[0] == rec_dim && v->type != NC_CHAR) {
if (v->has_data) {
fline(v->data_stmnt);
} else { /* generate data statement for FILL record */
size_t rec_len = 1;
for (idim = 1; idim < v->ndims; idim++) {
rec_len *= dims[v->dims[idim]].size;
}
sprintf(stmnt,"data %s /%lu * %s/", v->lname,
(unsigned long) rec_len,
f_fill_name(v->type));
fline(stmnt);
}
}
}
fline(" ");
for (ivar = 0; ivar < nvars; ivar++) {
struct vars *v = &vars[ivar];
/* if a record variable, declare starts and counts */
if (v->ndims > 0 && v->dims[0] == rec_dim) {
if (!v->has_data)
continue;
sprintf(stmnt, "* store %s", v->name);
fline(stmnt);
for (idim = 0; idim < v->ndims; idim++) {
sprintf(stmnt, "%s_start(%d) = 1", v->lname, idim+1);
fline(stmnt);
}
for (idim = v->ndims-1; idim > 0; idim--) {
sprintf(stmnt, "%s_count(%d) = %s_len", v->lname,
v->ndims - idim, dims[v->dims[idim]].lname);
fline(stmnt);
}
sprintf(stmnt, "%s_count(%d) = %s_nr", v->lname,
v->ndims, v->lname);
fline(stmnt);
if (v->type != NC_CHAR) {
sprintf(stmnt,
"iret = nf_put_vara_%s(ncid, %s_id, %s_start, %s_count, %s)",
nfftype(v->type), v->lname, v->lname, v->lname, v->lname);
} else {
sprintf(stmnt,
"iret = nf_put_vara_%s(ncid, %s_id, %s_start, %s_count, %s)",
nfftype(v->type), v->lname, v->lname, v->lname,
v->data_stmnt);
}
fline(stmnt);
fline("call check_err(iret)");
}
}
fline(" ");
fline("end");
fline(" ");
}
fline("subroutine check_err(iret)");
fline("integer iret");
fline("include 'netcdf.inc'");
fline("if (iret .ne. NF_NOERR) then");
fline("print *, nf_strerror(iret)");
fline("stop");
fline("endif");
fline("end");
}
