/* 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"); }