1/*********************************************************************
2 *   Copyright 1993, UCAR/Unidata
3 *   See netcdf/COPYRIGHT file for copying and redistribution conditions.
4 *   $Header: /upc/share/CVS/netcdf-3/ncgen/genf77.c,v 1.4 2010/05/17 23:26:44 dmh Exp $
5 *********************************************************************/
6
7#include "includes.h"
8#include "nc_iter.h"
9
10#ifdef ENABLE_F77
11
12#undef TRACE
13
14/*MNEMONIC*/
15#define USEMEMORY 1
16
17static Listf77procs = NULL; /* bodies of generated procedures */
18
19/* Forward */
20static void genf77_definevardata(Symbolvsym);
21static void genf77_defineattr(Symbolasym);
22static void genf77_definevardata(Symbol*);
23
24static void f77attrify(SymbolasymBytebufferbuf);
25static const char* f77varncid(Symbolvsym);
26static const char* f77dimncid(Symbolvsym);
27
28static const char* nfstype(nc_type nctype);
29static const char* nftype(nc_type type);
30static const char* nfstype(nc_type nctype);
31static const char* ncftype(nc_type type);
32static const char* nfdtype(nc_type type);
33
34static void f77skip(void);
35static void f77comment(char* cmt);
36static void f77fold(Bytebufferlines);
37static void f77flush(void);
38
39static void genf77_write(Generator*,Symbol*,Bytebuffer*,int,size_t*,size_t*);
40static void genf77_writevar(Generator*,Symbol*,Bytebuffer*,int,size_t*,size_t*);
41static void genf77_writeattr(Generator*,Symbol*,Bytebuffer*,int,size_t*,size_t*);
42
43
44/*
45 * Generate code for creating netCDF from in-memory structure.
46 */
47void
48gen_ncf77(const char *filename)
49{
50    int idimivariatt;
51    int ndimsnvarsnattsngatts;
52    char* cmode_string;
53
54    ndims = listlength(dimdefs);
55    nvars = listlength(vardefs);
56    natts = listlength(attdefs);
57    ngatts = listlength(gattdefs);
58
59    /* Construct the main program */
60
61    f77skip();
62    bbprintf0(stmt,"program %s\n", mainnamefilename);
63    codedump(stmt);
64    bbprintf0(stmt,"* input file %s", filename);
65    codeline("include 'netcdf.inc'");
66    f77comment("error status return");
67    codeline("integer stat");
68    f77comment("netCDF ncid");
69    codeline("integer  ncid");
70
71    /* create necessary declarations */
72
73    if (ndims > 0) {
74 f77skip();
75 f77comment("dimension lengths");
76 for(idim = 0; idim < ndimsidim++) {
77     Symboldsym = (Symbol*)listget(dimdefs,idim);
78     bbprintf0(stmt,"integer %s_len\n",f77name(dsym));
79     codedump(stmt);
80     if(dsym->dim.declsize == NC_UNLIMITED) {
81         bbprintf0(stmt,"parameter (%s_len = NF_UNLIMITED)\n",
82 f77name(dsym));
83     } else {
84 bbprintf0(stmt,"parameter (%s_len = %lu)\n",
85 f77name(dsym),
86 (unsigned long) dsym->dim.declsize);
87     }
88     codedump(stmt);
89 }
90    }
91    f77flush();
92
93    /* Now create the dimension id's */
94    if (ndims > 0) {
95 f77skip();
96 f77comment("dimension ids");
97 for(idim = 0; idim < ndimsidim++) {
98     Symboldsym = (Symbol*)listget(dimdefs,idim);
99     bbprintf0(stmt,"integer %s_dim\n",f77name(dsym));
100     codedump(stmt);
101 }
102    }
103
104    if (nvars > 0) {
105 f77skip();
106 f77comment("variable ids");
107 for(ivar = 0; ivar < nvarsivar++) {
108            Symbolvsym = (Symbol*)listget(vardefs,ivar);
109     bbprintf0(stmt,"integer %s;\n", f77varncid(vsym));
110     codedump(stmt);
111 }
112
113 f77skip();
114 f77comment("rank (number of dimensions) for each variable");
115 for(ivar = 0; ivar < nvarsivar++) {
116            Symbolvsym = (Symbol*)listget(vardefs,ivar);
117     bbprintf0(stmt,"integer %s_rank\n", f77name(vsym));
118     codedump(stmt);
119     bbprintf0(stmt,"parameter (%s_rank = %d)\n",
120     f77name(vsym),
121     vsym->typ.dimset.ndims);
122     codedump(stmt);
123 }
124        f77skip();
125        f77comment("variable shapes");
126 for(ivar = 0; ivar < nvarsivar++) {
127            Symbolvsym = (Symbol*)listget(vardefs,ivar);
128     if(vsym->typ.dimset.ndims > 0) {
129 bbprintf0(stmt,"integer %s_dims(%s_rank)\n",
130     f77name(vsym), f77name(vsym));
131 codedump(stmt);
132     }
133 }
134 /* variable declarations (for scalar and fixed sized only) */
135        f77skip();
136        f77comment("variable declarations");
137 for(ivar = 0; ivar < nvarsivar++) {
138            Symbolvsym = (Symbol*)listget(vardefs,ivar);
139     nc_type typecode = vsym->typ.basetype->typ.typecode;
140     if(vsym->data == NULL) continue;
141     if(typecode == NC_CHAR) continue;
142     if(vsym->typ.dimset.ndims == 0) {/* scalar */
143                bbprintf0(stmt,"%s %s\n",
144 nfdtype(typecode),f77name(vsym));
145                codedump(stmt);
146     } else if(vsym->typ.dimset.dimsyms[0]->dim.declsize != NC_UNLIMITED) {
147 int i;
148 Bytebufferdimstring = bbNew();
149 Dimsetdimset = &vsym->typ.dimset;
150                /* Compute the dimensions (in reverse order for fortran) */
151                for(i=dimset->ndims-1;i>=0;i--) {
152             char tmp[32];
153             Symboldsym = dimset->dimsyms[i];
154             nprintf(tmp,sizeof(tmp)," %lu",
155 (unsigned long)dsym->dim.declsize);
156             bbCat(dimstring,tmp);
157 }
158           commify(dimstring);
159                bbprintf0(stmt,"%s %s(%s)\n",
160     nfdtype(typecode),
161     f77name(vsym),
162     bbContents(dimstring));
163         codedump(stmt);
164                bbFree(dimstring);
165     }
166 }
167    }
168    f77flush();
169
170    /* F77 (as defined for ncgen3) requires per-type vectors for attributes */
171    if(ngatts > 0 || natts > 0) {
172 nc_type nctype;
173 int pertypesizes[NC_DOUBLE+1];
174 for(nctype=0;nctype<=NC_DOUBLE;nctype++) {pertypesizes[nctype] = 0;}
175 if(ngatts > 0) {
176         for(iatt = 0; iatt < ngattsiatt++) {
177         Symbolgasym = (Symbol*)listget(gattdefs,iatt);
178 int count = gasym->data->length;
179 int typecode = gasym->typ.basetype->typ.typecode;
180         if(count == 0) continue;
181 if(pertypesizes[typecode] < count)
182     pertypesizes[typecode] = count; /* keep max */
183     }
184 }
185 if(natts > 0) {
186         for(iatt = 0; iatt < nattsiatt++) {
187         Symbolasym = (Symbol*)listget(attdefs,iatt);
188 int count = asym->data->length;
189 int typecode = asym->typ.basetype->typ.typecode;
190         if(count == 0) continue;
191 if(pertypesizes[typecode] < count)
192     pertypesizes[typecode] = count; /* keep max */
193     }
194 }
195 /* Now, define the per-type vectors */
196        f77skip();
197        f77comment("attribute vectors");
198 for(nctype=NC_BYTE;nctype <= NC_DOUBLE;nctype++) {
199     char* basetype = "integer";
200            if(nctype == NC_FLOATbasetype = "real";
201            else if(nctype == NC_DOUBLEbasetype = "double precision";
202     if(pertypesizes[nctype] > 0) {
203         bbprintf0(stmt,"%s %sval(%d)\n",
204 basetypencftype(nctype),
205 pertypesizes[nctype]);
206         codedump(stmt);
207     }
208 }
209    }
210
211    /* create netCDF file, uses NC_CLOBBER mode */
212    f77skip();
213    f77skip();
214    f77comment("enter define mode");
215
216    if (!cmode_modifier) {
217 cmode_string = "nf_clobber";
218    } else if (cmode_modifier & NC_64BIT_OFFSET) {
219 cmode_string = "nf_clobber|nf_64bit_offset";
220    } else {
221        derror("unknown cmode modifier: %d",cmode_modifier);
222 cmode_string = "nf_clobber";
223    }
224    bbprintf0(stmt,"stat = nf_create('%s', %s, ncid);\n",
225  filename,cmode_string);
226    codedump(stmt);
227    codeline("call check_err(stat)");
228    f77flush();
229
230    /* define dimensions from info in dims array */
231    if (ndims > 0) {
232 f77skip();
233 f77comment("define dimensions");
234        for(idim = 0; idim < ndimsidim++) {
235            Symboldsym = (Symbol*)listget(dimdefs,idim);
236         bbprintf0(stmt,
237 "stat = nf_def_dim(ncid, %s, %s_len, %s);\n",
238                  codify(dsym->name), f77name(dsym), f77dimncid(dsym));
239     codedump(stmt);
240     codeline("call check_err(stat)");
241       }
242    }
243    f77flush();
244
245    /* define variables from info in vars array */
246    if (nvars > 0) {
247 f77skip();
248 f77comment("define variables");
249 for(ivar = 0; ivar < nvarsivar++) {
250            Symbolvsym = (Symbol*)listget(vardefs,ivar);
251            Symbolbasetype = vsym->typ.basetype;
252     Dimsetdimset = &vsym->typ.dimset;
253     f77skip();
254     if(dimset->ndims > 0) {
255 /* Remember; FORTRAN dimension order is reversed */
256         for(idim = 0; idim < dimset->ndimsidim++) {
257     int reverse = (dimset->ndims - idim) - 1;
258     Symboldsym = dimset->dimsyms[reverse];
259     bbprintf0(stmt,
260     "%s_dims(%d) = %s\n",
261     f77name(vsym),
262     idim+1,
263     f77dimncid(dsym));
264     codedump(stmt);
265 }
266     }
267     bbprintf0(stmt,
268 "stat = nf_def_var(ncid, %s, %s, %s_rank, %s, %s);\n",
269 codify(vsym->name),
270 nftype(basetype->typ.typecode),
271 f77name(vsym),
272 (dimset->ndims == 0?"0":poolcat(f77name(vsym),"_dims")),
273 f77varncid(vsym));
274     codedump(stmt);
275     codeline("call check_err(stat)");
276 }
277    }
278    f77flush();
279
280    /* Define the global attributes*/
281    if(ngatts > 0) {
282 f77skip();
283 f77comment("assign global attributes");
284 for(iatt = 0; iatt < ngattsiatt++) {
285     Symbolgasym = (Symbol*)listget(gattdefs,iatt);
286     genf77_defineattr(gasym);
287 }
288 f77skip();
289    }
290    f77flush();
291
292    /* Define the variable specific attributes*/
293    if(natts > 0) {
294 f77skip();
295 f77comment("assign per-variable attributes");
296 for(iatt = 0; iatt < nattsiatt++) {
297     Symbolasym = (Symbol*)listget(attdefs,iatt);
298     genf77_defineattr(asym);
299 }
300 f77skip();
301    }
302    f77flush();
303
304    if (nofill_flag) {
305        f77comment("don't initialize variables with fill values");
306 codeline("stat = nf_set_fill(ncid, NC_NOFILL, 0);");
307 codeline("call check_err(stat)");
308    }
309
310    f77skip();
311    f77comment("leave define mode");
312    codeline("stat = nf_enddef(ncid);");
313    codeline("call check_err(stat)");
314    f77skip();
315    f77flush();
316
317    if(!header_only) {
318        /* Assign scalar variable data and non-unlimited arrays in-line */
319        if(nvars > 0) {
320            f77skip();
321            f77skip();
322            f77comment("assign scalar and fixed dimension variable data");
323            for(ivar = 0; ivar < nvarsivar++) {
324                Symbolvsym = (Symbol*)listget(vardefs,ivar);
325                if(vsym->data == NULL) continue;
326                if(vsym->typ.dimset.ndims == 0)
327                    genf77_definevardata(vsym);
328            }
329            f77skip();
330        }
331
332        /* Invoke write procedures */
333        if(nvars > 0) {
334            Listcalllist;
335            f77skip();
336            f77skip();
337            f77comment("perform variable data writes");
338            for(ivar = 0; ivar < nvarsivar++) {
339                int i;
340                Symbolvsym = (Symbol*)listget(vardefs,ivar);
341                /* Call the procedures for writing unlimited variables */
342                if(vsym->data != NULL
343                    && vsym->typ.dimset.ndims > 0) {
344                    genf77_definevardata(vsym);
345                }
346                /* dump any calls */
347                generator_getstate(f77_generator,(void*)&calllist);
348                ASSERT(calllist != NULL);
349                for(i=0;i<listlength(calllist);i++) {
350                    char* callstmt = (char*)listget(calllist,i);
351                    codeline(callstmt);
352                }
353                listclear(calllist);
354            }
355        }
356
357        /* Close the file */
358        codeline("stat = nf_close(ncid)");
359        codeline("call check_err(stat)");
360        codeline("end");
361
362        /* Generate the write procedures */
363        if(listlength(f77procs) > 0) {
364     int i;
365         f77skip();
366            for(i=0;i<listlength(f77procs);i++) {
367             Bytebufferproctext = (Bytebuffer*)listget(f77procs,i);
368             codedump(proctext);
369             bbFree(proctext);
370         }
371         listfree(f77procs); f77procs = NULL;
372     f77skip();
373        }
374    }
375    f77flush();
376
377    /* Generate the check_err procedure */
378    f77skip();
379    codeline("subroutine check_err(stat)");
380    codeline("integer stat");
381    codeline("include 'netcdf.inc'");
382    codeline("if (stat .ne. NF_NOERR) then");
383    codeline("print *, nf_strerror(stat)");
384    codeline("stop");
385    codeline("endif");
386    codeline("end");
387    f77flush();
388
389}
390
391void
392cl_f77(void)
393{
394   /* already done above */
395}
396
397/* Compute the name for a given var's id*/
398/* Watch out: the result is a static*/
399static const char*
400f77varncid(Symbolvsym)
401{
402    const char* tmp1;
403    char* vartmp;
404    tmp1 = f77name(vsym);
405    vartmp = poolalloc(strlen(tmp1)+strlen("_id")+1);
406    strcpy(vartmp,tmp1);
407    strcat(vartmp,"_id");
408    return vartmp;
409}
410
411/* Compute the name for a given dim's id*/
412/* Watch out: the result is a static*/
413static const char*
414f77dimncid(Symboldsym)
415{
416    const char* tmp1;
417    char* dimtmp;
418    tmp1 = f77name(dsym);
419    dimtmp = poolalloc(strlen(tmp1)+strlen("_dim")+1);
420    strcpy(dimtmp,tmp1);
421    strcat(dimtmp,"_dim");
422    return dimtmp;
423}
424
425/* Compute the name for a given type*/
426const char*
427f77typename(Symboltsym)
428{
429    const char* name;
430    ASSERT(tsym->objectclass == NC_TYPE);
431    if(tsym->subclass == NC_PRIM)
432 name = nftype(tsym->typ.typecode);
433    else
434        name = f77name(tsym);
435    return name;
436}
437
438/* Compute the name for a given symbol*/
439const char*
440f77name(Symbolsym)
441{
442    char* name;
443    assert(sym->fqn != NULL);
444    name = codify(sym->fqn);
445    return name;
446}
447
448static void
449genf77_defineattr(Symbolasym)
450{
451    Bytebuffercode = bbNew();
452    Listoldstate = NULL;
453    generator_getstate(f77_generator,(void*)&oldstate);
454    listfree(oldstate);
455    generator_reset(f77_generator,(void*)listnew());
456    generate_attrdata(asym,f77_generator,(Writer)genf77_write,code);
457    bbFree(code);
458}
459
460static void
461f77skip(void)
462{
463    codeline("");
464}
465
466static void
467f77comment(char* cmt)
468{
469    codepartial("* ");
470    codeline(cmt);
471}
472
473static void
474f77fold(Bytebufferlines)
475{
476    char* s;
477    char* line0;
478    char* linen;
479    static char trimchars[] = " \t\r\n";
480
481    s = bbDup(lines);
482    bbClear(lines);
483    line0 = s;
484    /* Start by trimming leading blanks and empty lines */
485    while(*line0 && strchr(trimchars,*line0) != NULLline0++;
486    if(*line0 == '\0') return;
487    for(;;) {
488 size_t linelen;
489 linen = line0;
490 /* collect a single line */
491 while(*linen != '\n' && *linen != '\0') linen++;
492 if(*linen == '\0') break;
493 linen++; /* include trailing newline */
494 linelen = (linen - line0);
495 /* handle comments and empty lines */
496 if(*line0 == '*' || linelen == 1) {
497     bbAppendn(lines,line0,linelen);
498     line0 = linen;
499     continue;
500 }
501 /* Not a comment */
502        /* check to see if we need to fold it (watch out for newline)*/
503 if(linelen <= (F77_MAX_STMT+1)) { /* no folding needed */
504     bbCat(lines,"      "); /*indent*/
505     bbAppendn(lines,line0,linelen);
506     line0 = linen;
507     continue;
508 }
509 /* We need to fold */
510        bbCat(lines,"      "); /*indent first line */
511 while(linelen > F77_MAX_STMT) {
512     int incr = F77_MAX_STMT;
513     /* Check to ensure we are folding at a legal point */
514     if(*(line0+(incr-1)) == '\\') incr--;
515     bbAppendn(lines,line0,incr);
516     bbCat(lines,"\n     1"); /* comment extender */
517     line0 += incr;
518     linelen -= incr;
519 }
520 /* Do last part of the line */
521 bbAppendn(lines,line0,linelen);
522 line0 = linen;
523    }
524}
525
526static void
527f77flush(void)
528{
529    if(bbLength(codebuffer) > 0) {
530        bbNull(codebuffer);
531 f77fold(codebuffer);
532        codeflush();
533    }
534}
535
536static char* f77attrifyr(Symbol*, char* pBytebufferbuf);
537
538static void
539f77attrify(SymbolasymBytebufferbuf)
540{
541    char* list,*p;
542
543    if(bbLength(buf) == 0) return;
544    list = bbDup(buf);
545    p = list;
546    bbClear(buf);
547    f77attrifyr(asym,p,buf);
548    bbNull(buf);
549    efree(list);
550}
551
552static char*
553f77attrifyr(Symbolasym, char* pBytebufferbuf)
554{
555    Symbolbasetype = asym->typ.basetype;
556    nc_type typecode = basetype->typ.typecode;
557    int c;
558    int index;
559    char where[1024];
560
561    nprintf(where,sizeof(where),"%sval",ncftype(typecode));
562    for(index=1;(c=*p);) {
563 if(c == ' ' || c == ',') {p++; continue;}
564 bbprintf0(stmt,"%s(%d) = ",where,index);
565 bbCatbuf(buf,stmt);
566        p=word(p,buf);
567        bbCat(buf,"\n");
568 index++;
569    }
570    return p;
571}
572
573#ifdef USE_NETCDF4
574#if 0
575/* Result is pool alloc'd*/
576static char*
577f77prefixed(Listprefix, char* suffix, char* separator)
578{
579    int slen;
580    int plen;
581    int i;
582    char* result;
583
584    ASSERT(suffix != NULL);
585    plen = prefixlen(prefix);
586    if(prefix == NULL || plen == 0) return codify(suffix);
587    /* plen > 0*/
588    slen = 0;
589    for(i=0;i<plen;i++) {
590 Symbolsym = (Symbol*)listget(prefix,i);
591 slen += (strlen(sym->name)+strlen(separator));
592    }
593    slen += strlen(suffix);
594    slen++; /* for null terminator*/
595    result = poolalloc(slen);
596    result[0] = '\0';
597    /* Leave off the root*/
598    i = (rootgroup == (Symbol*)listget(prefix,0))?1:0;
599    for(;i<plen;i++) {
600 Symbolsym = (Symbol*)listget(prefix,i);
601        strcat(result,sym->name); /* append "<prefix[i]/>"*/
602 strcat(result,separator);
603    }
604    strcat(result,suffix); /* append "<suffix>"*/
605    return result;
606}
607#endif
608#endif
609
610/* return FORTRAN name for netCDF type, given type code */
611static const char*
612nftype(nc_type type)
613{
614    switch (type) {
615      case NC_CHAR: return "nf_char";
616      case NC_BYTE: return "nf_byte";
617      case NC_SHORT: return "nf_short";
618      case NC_INT: return "nf_int";
619      case NC_FLOAT: return "nf_float";
620      case NC_DOUBLE: return "nf_double";
621      default: PANIC("nctype: bad type code");
622    }
623    return NULL;
624}
625
626/* return FORTRAN declaration type for given type code */
627static const char*
628nfdtype(nc_type type)
629{
630    switch (type) {
631      case NC_CHAR: return "integer";
632      case NC_BYTE: return "integer";
633      case NC_SHORT: return "integer";
634      case NC_INT: return "integer";
635      case NC_FLOAT: return "real ";
636      case NC_DOUBLE: return "double precision";
637      default: PANIC("nctype: bad type code");
638    }
639    return NULL;
640}
641
642/*
643 * Return proper _put_var_ suffix for given nc_type
644 */
645static const char*
646nfstype(nc_type nctype)
647{
648    switch (nctype) {
649      case NC_CHAR:
650 return "text";
651      case NC_BYTE:
652 return "int";
653      case NC_SHORT:
654 return "int";
655      case NC_INT:
656 return "int";
657      case NC_FLOAT:
658 return "real";
659      case NC_DOUBLE:
660 return "double";
661      default:
662 derror("ncstype: bad type code: %d",nctype);
663 return 0;
664    }
665}
666
667/*
668 * Return FORTRAN type name for netCDF attribute type
669 */
670static const char*
671ncftype(nc_type type)
672{
673    switch (type) {
674      case NC_CHAR:
675 return "text";
676      case NC_BYTE:
677 return "int1";
678      case NC_SHORT:
679 return "int2";
680      case NC_INT:
681 return "int";
682      case NC_FLOAT:
683 return "real";
684      case NC_DOUBLE:
685 return "double";
686      default:
687 PANIC1("ncctype: bad type code:%d",type);
688    }
689    return 0;
690}
691
692static void
693genf77_definevardata(Symbolvsym)
694{
695    Bytebuffercode = bbNew();
696    Listoldstate = NULL;
697    generator_getstate(f77_generator,(void*)&oldstate);
698    listfree(oldstate);
699    generator_reset(f77_generator,(void*)listnew());
700    generate_vardata(vsym,f77_generator,(Writer)genf77_write,code);
701    bbFree(code);
702}
703
704static void
705genf77_write(GeneratorgeneratorSymbolsymBytebuffercode,
706             int rank, size_t* start, size_t* count)
707{
708    if(sym->objectclass == NC_ATT)
709 genf77_writeattr(generator,sym,code,rank,start,count);
710    else if(sym->objectclass == NC_VAR) {
711 genf77_writevar(generator,sym,code,rank,start,count);
712    }
713    else
714 PANIC("illegal symbol for genf77_write");
715}
716
717static void
718genf77_writevar(GeneratorgeneratorSymbolvsymBytebuffercode,
719           int rank, size_t* start, size_t* count)
720{
721    Dimsetdimset = &vsym->typ.dimset;
722    int typecode = vsym->typ.basetype->typ.typecode;
723    int i;
724
725    /* Deal with character variables specially */
726    if(typecode == NC_CHAR) {
727        f77quotestring(code);
728        bbprintf0(stmt,"stat = nf_put_var_%s(ncid, %s, %s)\n",
729         nfstype(typecode),
730 f77varncid(vsym),
731 bbContents(code));
732        codedump(stmt);
733        codeline("call check_err(stat)");
734 f77skip();
735    } else if(rank == 0) {
736 commify(code); /* insert commas as needed */
737        bbprintf0(stmt,"data %s /%s/\n",
738     f77name(vsym),bbContents(code));
739 codedump(stmt);
740        bbprintf0(stmt,"stat = nf_put_var_%s(ncid, %s, %s)\n",
741         nfstype(typecode),
742 f77varncid(vsym),
743 f77name(vsym));
744        codedump(stmt);
745        codeline("call check_err(stat)");
746 f77skip();
747    } else { /* rank > 0 && typecode != NC_CHAR*/
748        char* dimstring;
749 int index = listlength(f77procs);
750 Bytebufferproctext;
751 Bytebuffersave;
752 Listcalllist;
753
754 /* Generate the call to the procedure */
755        bbprintf0(stmt,"call write_%s_%d(ncid,%s_id_%d)\n",
756          f77name(vsym),index,f77name(vsym));
757 /* save in the generator state */
758 generator_getstate(generator,(void*)&calllist);
759 ASSERT(calllist != NULL);
760 listpush(calllist,(void*)bbDup(stmt));
761
762        /* Construct the procedure body and save it */
763 proctext = bbNew();
764 save = codebuffer;
765 codebuffer = proctext;
766 f77skip();
767        bbprintf0(stmt,"subroutine write_%s_%d(ncid,%s_id)\n",
768                        f77name(vsym),index,f77name(vsym));
769        codedump(stmt);
770        codeline("integer ncid");
771        bbprintf0(stmt,"integer %s_id\n",f77name(vsym));
772        codedump(stmt);
773        codeline("include 'netcdf.inc'");
774        codeline("integer stat");
775        f77skip();
776        bbprintf0(stmt,"integer %s_start(%u)\n",
777                        f77name(vsym),(unsigned int)rank);
778        codedump(stmt);
779        bbprintf0(stmt,"integer %s_count(%u)\n",
780                        f77name(vsym),(unsigned int)rank);
781        codedump(stmt);
782        f77skip();
783
784        /* Compute the dimensions (in reverse order for fortran) */
785 bbClear(stmt);
786        for(i=rank-1;i>=0;i--) {
787            char tmp[32];
788            nprintf(tmp,sizeof(tmp),"%s%lu",
789 (i==(rank-1)?"":","),
790 count[i]);
791            bbCat(stmt,tmp);
792        }
793        dimstring = bbDup(stmt);
794        commify(code);
795        bbprintf0(stmt,"%s %s(%s)\n",
796                                nfdtype(typecode),
797                                f77name(vsym),
798                                dimstring);
799        efree(dimstring);
800        codedump(stmt);
801
802        /* Generate the data // statement */
803 commify(code); /* insert commas as needed */
804        bbprintf0(stmt,"data %s /",f77name(vsym));
805        bbCatbuf(stmt,code);
806        bbCat(stmt,"/\n");
807        codedump(stmt);
808
809 /* Set the values for the start and count sets
810    but in reverse order
811 */
812 for(i=0;i<dimset->ndims;i++) {
813     int reverse = (dimset->ndims - i) - 1;
814     bbprintf0(stmt,"%s_start(%d) = %lu\n",
815     f77name(vsym),
816     i+1,
817     start[reverse]+1); /* +1 for FORTRAN */
818     codedump(stmt);
819 }
820 for(i=0;i<dimset->ndims;i++) {
821     int reverse = (dimset->ndims - i) - 1;
822     bbprintf0(stmt,"%s_count(%d) = %lu\n",
823 f77name(vsym),
824 i+1,
825 count[reverse]);
826     codedump(stmt);
827 }
828 bbprintf0(stmt,"stat = nf_put_vara_%s(ncid, %s, %s_start, %s_count, ",
829 nfstype(typecode),
830 f77varncid(vsym),
831 f77name(vsym),
832 f77name(vsym));
833 codedump(stmt);
834 if(typecode == NC_CHAR) {
835     f77quotestring(code);
836     codedump(code);
837 } else {
838     codeprintf("%s",f77name(vsym));
839 }
840 codeline(")");
841 codeline("call check_err(stat)");
842 /* Close off the procedure */
843 codeline("end");
844        /* save the generated procedure(s) */
845 if(f77procs == NULLf77procs = listnew();
846        listpush(f77procs,(void*)codebuffer);
847        codebuffer = save;
848    }
849}
850
851static void
852genf77_writeattr(GeneratorgeneratorSymbolasymBytebuffercode,
853        int rank, size_t* start, size_t* count)
854{
855    Symbolbasetype = asym->typ.basetype;
856    /* default assumption */
857    size_t len = asym->data==NULL?0:asym->data->length;
858
859    bbprintf0(stmt,"* define %s\n",asym->name);
860    codedump(stmt);
861
862    /* Use the specialized put_att_XX routines if possible*/
863    switch (basetype->typ.typecode) {
864    case NC_BYTE:
865    case NC_SHORT:
866    case NC_INT:
867    case NC_FLOAT:
868    case NC_DOUBLE:
869 f77attrify(asym,code);
870 codedump(code);
871 bbClear(code);
872 bbprintf0(stmt,"stat = nf_put_att_%s(ncid, %s, %s, %s, %lu, %sval)\n",
873 nfstype(basetype->typ.typecode),
874 (asym->att.var == NULL?"NF_GLOBAL"
875       :f77varncid(asym->att.var)),
876 codify(asym->name),
877 nftype(basetype->typ.typecode),
878 len,
879 ncftype(basetype->typ.typecode));
880 codedump(stmt);
881 break;
882
883    case NC_CHAR:
884 len = bbLength(code);
885 f77quotestring(code);
886 if(len==0) len++;
887 bbprintf0(stmt,"stat = nf_put_att_text(ncid, %s, %s, %lu, ",
888 (asym->att.var == NULL?"NF_GLOBAL"
889       :f77varncid(asym->att.var)),
890 codify(asym->name),
891 len);
892 codedump(stmt);
893 codedump(code);
894 codeline(")");
895 break;
896
897
898    default: /* User defined type */
899 verror("Non-classic type: %s",nctypename(basetype->typ.typecode));
900 break;
901    }
902
903    codeline("call check_err(stat)");
904}
905
906#endif /*ENABLE_F77*/


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