source: lmdz_wrf/trunk/WRFV3/tools/reg_parse.c @ 1185

Last change on this file since 1185 was 1, checked in by lfita, 11 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 36.4 KB
Line 
1#include <stdio.h>
2#include <stdlib.h>
3#include <string.h>
4#ifdef _WIN32
5# define rindex(X,Y) strrchr(X,Y)
6# define index(X,Y) strchr(X,Y)
7#else
8# include <strings.h>
9#endif
10
11#include "registry.h"
12#include "protos.h"
13#include "data.h"
14#include "sym.h"
15
16/* read in the Registry file and build the internal representation of the registry */
17
18#define MAXTOKENS 5000 /*changed MAXTOKENS from 1000 to 5000 by Manish Shrivastava on 01/28/2010*/
19
20/* fields for state entries (note, these get converted to field entries in the
21   reg_parse routine; therefore, only TABLE needs to be looked at */
22#define TABLE 0
23
24/* fields for field entries (TABLE="typedef" and, with some munging,  TABLE="state") */
25#define FIELD_OF        1
26#define FIELD_TYPE     2
27#define FIELD_SYM      3
28#define FIELD_DIMS     4
29#define FIELD_USE      5
30#define FIELD_NTL      6
31#define FIELD_STAG     7
32#define FIELD_IO       8
33#define FIELD_DNAME    9
34#define FIELD_DESCRIP 10
35#define FIELD_UNITS   11
36
37#define F_OF       0
38#define F_TYPE     1
39#define F_SYM      2
40#define F_DIMS     3
41#define F_USE      4
42#define F_NTL      5
43#define F_STAG     6
44#define F_IO       7
45#define F_DNAME    8
46#define F_DESCRIP  9
47#define F_UNITS   10
48
49/* fields for rconfig entries (RCNF) */
50#define RCNF_TYPE_PRE       1
51#define RCNF_SYM_PRE        2
52#define RCNF_HOWSET_PRE     3
53#define RCNF_NENTRIES_PRE   4
54#define RCNF_DEFAULT_PRE    5
55#define RCNF_IO_PRE         6
56#define RCNF_DNAME_PRE      7
57#define RCNF_DESCRIP_PRE    8
58#define RCNF_UNITS_PRE      9
59
60#define RCNF_TYPE       2
61#define RCNF_SYM        3
62#define RCNF_USE        FIELD_USE
63#define RCNF_IO         FIELD_IO
64#define RCNF_DNAME      FIELD_DNAME
65#define RCNF_DESCRIP    FIELD_DESCRIP
66#define RCNF_UNITS      FIELD_UNITS
67#define RCNF_HOWSET    20
68#define RCNF_NENTRIES  21
69#define RCNF_DEFAULT   22
70
71/* fields for dimension entries (TABLE="dimspec") */
72#define DIM_NAME       1
73#define DIM_ORDER      2
74#define DIM_SPEC       3
75#define DIM_ORIENT     4
76#define DIM_DATA_NAME  5
77
78#define PKG_SYM            1
79#define PKG_ASSOC          2
80#define PKG_STATEVARS      3
81#define PKG_4DSCALARS      4
82
83#define COMM_ID            1
84#define COMM_USE           2
85#define COMM_DEFINE        3
86
87static int ntracers = 0 ;
88static char tracers[1000][100] ;
89
90int
91pre_parse( char * dir, FILE * infile, FILE * outfile )
92{
93  /* Decreased size for SOA from 8192 to 8000--double check if necessary, Manish Shrivastava 2010 */
94  char inln[8000], parseline[8000], parseline_save[8000] ;
95  int found ; 
96  char *p, *q ;
97  char *tokens[MAXTOKENS], *toktmp[MAXTOKENS], newdims[NAMELEN_LONG], newdims4d[NAMELEN_LONG],newname[NAMELEN_LONG] ;
98  int i, ii, len_of_tok ;
99  char x, xstr[NAMELEN_LONG] ;
100  int is4d, wantstend, wantsbdy ;
101  int ifdef_stack_ptr = 0 ;
102  int ifdef_stack[100] ;
103  int inquote, retval ;
104
105  ifdef_stack[0] = 1 ;
106  retval = 0 ;
107
108  parseline[0] = '\0' ;
109/* main parse loop over registry lines */
110  /* Had to increase size for SOA from 4096 to 7000, Manish Shrivastava 2010 */
111  while ( fgets ( inln , 7000 , infile ) != NULL )
112  {
113
114/*** preprocessing directives ****/
115    /* look for an include statement */
116    for ( p = inln ; ( *p == ' ' || *p == '     ' ) && *p != '\0' ; p++ ) ;
117    if ( !strncmp( p , "include", 7 ) &&  ! ( ifdef_stack_ptr >= 0 && ! ifdef_stack[ifdef_stack_ptr] ) ) {
118      FILE *include_fp ;
119      char include_file_name[128] ;
120      p += 7 ; for ( ; ( *p == ' ' || *p == '   ' ) && *p != '\0' ; p++ ) ;
121      if ( strlen( p ) > 127 ) { fprintf(stderr,"Registry warning: invalid include file name: %s\n", p ) ; }
122      else {
123        sprintf( include_file_name , "%s/%s", dir , p ) ;
124        if ( (p=index(include_file_name,'\n')) != NULL ) *p = '\0' ;
125        fprintf(stderr,"opening %s\n",include_file_name) ;
126        if (( include_fp = fopen( include_file_name , "r" )) != NULL ) {
127
128          fprintf(stderr,"including %s\n",include_file_name ) ;
129          pre_parse( dir , include_fp , outfile ) ;
130
131          fclose( include_fp ) ;
132        } else {
133          fprintf(stderr,"Registry warning: cannot open %s. Ignoring.\n", include_file_name ) ;
134        } 
135      }
136    }
137    else if ( !strncmp( p , "ifdef", 5 ) ) {
138      char value[32] ;
139      p += 5 ; for ( ; ( *p == ' ' || *p == '   ' ) && *p != '\0' ; p++ ) ;
140      strncpy(value, p, 31 ) ; value[31] = '\0' ;
141      if ( (p=index(value,'\n')) != NULL ) *p = '\0' ;
142      if ( (p=index(value,' ')) != NULL ) *p = '\0' ; if ( (p=index(value,'     ')) != NULL ) *p = '\0' ; 
143      ifdef_stack_ptr++ ;
144      ifdef_stack[ifdef_stack_ptr] = ( sym_get(value) != NULL && ifdef_stack[ifdef_stack_ptr-1] ) ;
145      if ( ifdef_stack_ptr >= 100 ) { fprintf(stderr,"Registry fatal: too many nested ifdefs\n") ; exit(1) ; }
146      continue ;
147    }
148    else if ( !strncmp( p , "ifndef", 6 ) ) {
149      char value[32] ;
150      p += 6 ; for ( ; ( *p == ' ' || *p == '   ' ) && *p != '\0' ; p++ ) ;
151      strncpy(value, p, 31 ) ; value[31] = '\0' ;
152      if ( (p=index(value,'\n')) != NULL ) *p = '\0' ;
153      if ( (p=index(value,' ')) != NULL ) *p = '\0' ; if ( (p=index(value,'     ')) != NULL ) *p = '\0' ; 
154      ifdef_stack_ptr++ ;
155      ifdef_stack[ifdef_stack_ptr] = ( sym_get(value) == NULL && ifdef_stack[ifdef_stack_ptr-1] ) ;
156      if ( ifdef_stack_ptr >= 100 ) { fprintf(stderr,"Registry fatal: too many nested ifdefs\n") ; exit(1) ; }
157      continue ;
158    }
159    else if ( !strncmp( p , "endif", 5 ) ) {
160      ifdef_stack_ptr-- ; 
161      if ( ifdef_stack_ptr < 0 ) { fprintf(stderr,"Registry fatal: unmatched endif\n") ; exit(1) ; }
162      continue ;
163    }
164    else if ( !strncmp( p , "define", 6 ) ) {
165      char value[32] ;
166      p += 6 ; for ( ; ( *p == ' ' || *p == '   ' ) && *p != '\0' ; p++ ) ;
167      strncpy(value, p, 31 ) ; value[31] = '\0' ;
168      if ( (p=index(value,'\n')) != NULL ) *p = '\0' ;
169      if ( (p=index(value,' ')) != NULL ) *p = '\0' ; if ( (p=index(value,'     ')) != NULL ) *p = '\0' ; 
170      sym_add( value ) ;
171      continue ;
172    }
173    if ( ifdef_stack_ptr >= 0 && ! ifdef_stack[ifdef_stack_ptr] ) continue ;
174/*** end of preprocessing directives ****/
175
176    strcat( parseline , inln ) ;
177
178    /* allow \ to continue the end of a line */
179    if (( p = index( parseline,  '\\'  )) != NULL )
180    {
181      if ( *(p+1) == '\n' || *(p+1) == '\0' )
182      {
183        *p = '\0' ;
184        continue ;  /* go get another line */
185      }
186    }
187    make_lower( parseline ) ;
188
189    if (( p = index( parseline , '\n' )) != NULL  ) *p = '\0' ; /* discard newlines */
190
191    /* check line and zap any # characters that are in double quotes */
192
193    for ( p = parseline, inquote = 0 ; *p ; p++ ) {
194      if      ( *p == '"' && inquote ) inquote = 0 ;
195      else if ( *p == '"' && !inquote ) inquote = 1 ;
196      else if ( *p == '#' && inquote ) *p = ' ' ;
197      else if ( *p == '#' && !inquote ) { *p = '\0' ; break ; }
198    }
199    if ( inquote ) { retval=1 ; fprintf(stderr,"Registry error: unbalanced quotes in line:\n%s\n",parseline) ;}
200
201    for ( i = 0 ; i < MAXTOKENS ; i++ ) tokens[i] = NULL ;
202    i = 0 ;
203
204    strcpy( parseline_save, parseline ) ;
205
206    if ((tokens[i] = my_strtok(parseline)) != NULL ) i++ ;
207    while (( tokens[i] = my_strtok(NULL) ) != NULL && i < MAXTOKENS ) i++ ;
208    if ( i <= 0 ) continue ;
209
210    for ( i = 0 ; i < MAXTOKENS ; i++ )
211    {
212      if ( tokens[i] == NULL ) tokens[i] = "-" ;
213    }
214/* remove quotes from quoted entries */
215    for ( i = 0 ; i < MAXTOKENS ; i++ )
216    {
217      char * pp ;
218      if ( tokens[i][0] == '"' ) tokens[i]++ ;
219      if ((pp=rindex( tokens[i], '"' )) != NULL ) *pp = '\0' ;
220    }
221    if      ( !strcmp( tokens[ TABLE ] , "state" ) )
222    {
223        int inbrace = 0 ;
224        strcpy( newdims, "" ) ;
225        strcpy( newdims4d, "" ) ;
226        is4d = 0 ; wantstend = 0 ; wantsbdy = 0 ; 
227        for ( i = 0 ; i < (len_of_tok = strlen(tokens[F_DIMS])) ; i++ )
228        {
229          x = tolower(tokens[F_DIMS][i]) ;
230          if ( x == '{' ) { inbrace = 1 ; }
231          if ( x == '}' ) { inbrace = 0 ; }
232          if ( x >= 'a' && x <= 'z' && !inbrace ) {
233            if ( x == 'f' ) { is4d = 1 ; }
234            if ( x == 't' ) { wantstend = 1 ; }
235            if ( x == 'b' ) { wantsbdy = 1 ; }
236          }
237          sprintf(xstr,"%c",x) ;
238          if ( x != 'b' || inbrace ) strcat ( newdims , xstr ) ;
239          if ( x != 'f' && x != 't' || inbrace ) strcat( newdims4d , xstr ) ;
240
241        }
242        if ( wantsbdy ) {
243
244
245/* first re-gurg the original entry without the b in the dims */
246
247 fprintf( outfile,"state %s %s %s %s %s %s %s \"%s\" \"%s\" \"%s\"\n",tokens[F_TYPE],tokens[F_SYM], newdims,
248                  tokens[F_USE],tokens[F_NTL],tokens[F_STAG],tokens[F_IO],
249                  tokens[F_DNAME],tokens[F_DESCRIP],tokens[F_UNITS] ) ;
250
251          if ( strcmp( tokens[F_SYM] , "-" ) ) {  /* if not unnamed, as can happen with first 4d tracer */
252/* next, output some additional entries for the boundary arrays for these guys */
253            if ( is4d == 1 ) {
254              for ( i = 0, found = 0 ; i < ntracers ; i++ ) {
255                if ( !strcmp( tokens[F_USE] , tracers[i] ) ) found = 1 ; 
256              }
257              if ( found == 0 ) {
258                sprintf(tracers[ntracers],tokens[F_USE]) ;
259                ntracers++ ;
260
261/* add entries for _b and _bt arrays */
262
263 sprintf(newname,"%s_b",tokens[F_USE]) ;
264 fprintf( outfile,"state %s %s %s %s %s %s %s \"%s\" \"bdy %s\" \"%s\"\n",tokens[F_TYPE],newname,newdims4d,
265                  "_4d_bdy_array_","-",tokens[F_STAG],"b",
266                  newname,tokens[F_DESCRIP],tokens[F_UNITS] ) ;
267
268 sprintf(newname,"%s_bt",tokens[F_USE]) ;
269 fprintf( outfile,"state %s %s %s %s %s %s %s \"%s\" \"bdy tend %s\" \"(%s)/dt\"\n",tokens[F_TYPE],newname,newdims4d,
270                  "_4d_bdy_array_","-",tokens[F_STAG],"b",
271                  newname,tokens[F_DESCRIP],tokens[F_UNITS] ) ;
272
273              }
274            } else {
275
276/* add entries for _b and _bt arrays */
277
278 sprintf(newname,"%s_b",tokens[F_SYM]) ;
279 fprintf( outfile,"state %s %s %s %s %s %s %s \"%s\" \"bdy %s\" \"%s\"\n",tokens[F_TYPE],newname,tokens[F_DIMS],
280                  tokens[F_USE],"-",tokens[F_STAG],"b",
281                  newname,tokens[F_DESCRIP],tokens[F_UNITS] ) ;
282
283 sprintf(newname,"%s_bt",tokens[F_SYM]) ;
284 fprintf( outfile,"state %s %s %s %s %s %s %s \"%s\" \"bdy tend %s\" \"(%s)/dt\"\n",tokens[F_TYPE],newname,tokens[F_DIMS],
285                  tokens[F_USE],"-",tokens[F_STAG],"b",
286                  newname,tokens[F_DESCRIP],tokens[F_UNITS] ) ;
287
288            }
289          }
290          parseline[0] = '\0' ;  /* reset parseline */
291          continue ;
292        }
293    }
294normal:
295    /* otherwise output the line as is */
296    fprintf(outfile,"%s\n",parseline_save) ;
297    parseline[0] = '\0' ;  /* reset parseline */
298  }
299  return(retval) ;
300}
301
302int
303reg_parse( FILE * infile )
304{
305  /* Had to increase size for SOA from 4096 to 7000, Manish Shrivastava 2010 */
306  char inln[7000], parseline[7000] ;
307  char *p, *q ;
308  char *tokens[MAXTOKENS], *toktmp[MAXTOKENS] ; 
309  int i, ii ;
310  int defining_state_field, defining_rconfig_field, defining_i1_field ;
311
312  parseline[0] = '\0' ;
313
314  max_time_level = 1 ;
315
316/* main parse loop over registry lines */
317/* Had to increase size for SOA from 4096 to 7000, Manish Shrivastava 2010 */
318  while ( fgets ( inln , 7000 , infile ) != NULL )
319  {
320    strcat( parseline , inln ) ; 
321    /* allow \ to continue the end of a line */
322    if (( p = index( parseline,  '\\'  )) != NULL )
323    {
324      if ( *(p+1) == '\n' || *(p+1) == '\0' )
325      {
326        *p = '\0' ;
327        continue ;  /* go get another line */
328      }
329    }
330
331    make_lower( parseline ) ;
332    if (( p = index( parseline , '#' ))  != NULL  ) *p = '\0' ; /* discard comments (dont worry about quotes for now) */
333    if (( p = index( parseline , '\n' )) != NULL  ) *p = '\0' ; /* discard newlines */
334    for ( i = 0 ; i < MAXTOKENS ; i++ ) tokens[i] = NULL ; 
335    i = 0 ;
336
337    if ((tokens[i] = my_strtok(parseline)) != NULL ) i++ ; 
338
339    while (( tokens[i] = my_strtok(NULL) ) != NULL && i < MAXTOKENS ) i++ ;
340    if ( i <= 0 ) continue ;
341
342    for ( i = 0 ; i < MAXTOKENS ; i++ )
343    {
344      if ( tokens[i] == NULL ) tokens[i] = "-" ;
345    }
346
347/* remove quotes from quoted entries */
348    for ( i = 0 ; i < MAXTOKENS ; i++ )
349    {
350      char * pp ;
351      if ( tokens[i][0] == '"' ) tokens[i]++ ;
352      if ((pp=rindex( tokens[i], '"' )) != NULL ) *pp = '\0' ;
353    }
354
355    defining_state_field = 0 ;
356    defining_rconfig_field = 0 ;
357    defining_i1_field = 0 ;
358
359/* state entry */
360    if      ( !strcmp( tokens[ TABLE ] , "state" ) )
361    {
362      /* turn a state entry into a typedef to define a field in the top-level built-in type domain */
363      tokens[TABLE] = "typedef" ;
364      for ( i = MAXTOKENS-1 ; i >= 2 ; i-- ) tokens[i] = tokens[i-1] ; /* shift the fields to the left */
365      tokens[FIELD_OF] = "domain" ;
366                 if ( !strcmp( tokens[FIELD_TYPE], "double" ) ) tokens[FIELD_TYPE] = "doubleprecision" ; 
367      defining_state_field = 1 ;
368    }
369    if      ( !strcmp( tokens[ TABLE ] , "rconfig" ) )
370    {
371
372      char *pp, value[256] ;
373      for ( pp = tokens[RCNF_SYM_PRE] ; (*pp == ' ' || *pp == ' ') && *pp ; pp++ ) ;
374      sprintf(value, "RCONFIG_%s" ,pp) ;
375      if ( sym_get(value) == NULL ) {
376        sym_add(value) ;
377      } else {
378        parseline[0] = '\0' ;  /* reset parseline */
379        continue ;
380      }
381
382      /* turn a rconfig entry into a typedef to define a field in the top-level built-in type domain */
383      for ( i = 0 ; i < MAXTOKENS ; i++ ) { toktmp[i] = tokens[i] ; tokens[i] = "-" ; }
384      tokens[TABLE] = "typedef" ;
385      tokens[FIELD_OF]       = "domain" ;
386      tokens[RCNF_TYPE]      = toktmp[RCNF_TYPE_PRE] ;
387                 if ( !strcmp( tokens[RCNF_TYPE], "double" ) ) tokens[RCNF_TYPE] = "doubleprecision" ; 
388      tokens[RCNF_SYM]       = toktmp[RCNF_SYM_PRE] ;
389      tokens[RCNF_IO]        = toktmp[RCNF_IO_PRE] ;
390      tokens[RCNF_DNAME]     = toktmp[RCNF_DNAME_PRE] ;
391      tokens[RCNF_USE]       = "-" ;
392      tokens[RCNF_DESCRIP]   = toktmp[RCNF_DESCRIP_PRE] ;
393      tokens[RCNF_UNITS]     = toktmp[RCNF_UNITS_PRE] ;
394      tokens[RCNF_HOWSET]    = toktmp[RCNF_HOWSET_PRE] ;
395      tokens[RCNF_NENTRIES]  = toktmp[RCNF_NENTRIES_PRE] ;
396      tokens[RCNF_DEFAULT]   = toktmp[RCNF_DEFAULT_PRE] ;
397      defining_rconfig_field = 1 ;
398    }
399    if      ( !strcmp( tokens[ TABLE ] , "i1" ) )
400    {
401      /* turn a state entry into a typedef to define a field in
402         the top-level built-in type domain */
403      tokens[TABLE] = "typedef" ;
404      /* shift the fields to the left */
405      for ( i = MAXTOKENS-1 ; i >= 2 ; i-- ) tokens[i] = tokens[i-1] ; 
406      tokens[FIELD_OF] = "domain" ;
407                 if ( !strcmp( tokens[FIELD_TYPE], "double" ) ) tokens[FIELD_TYPE] = "doubleprecision" ; 
408      defining_i1_field = 1 ;
409    }
410
411    /* NOTE: fall through */
412
413/* typedef entry */
414    if ( !strcmp( tokens[ TABLE ] , "typedef" ) )
415    {
416      node_t * field_struct ;
417      node_t * type_struct ;
418
419      if ( !defining_state_field && ! defining_i1_field && 
420           !defining_rconfig_field && !strcmp(tokens[FIELD_OF],"domain") )
421       { fprintf(stderr,"Registry warning: 'domain' is a reserved registry type name. Cannot 'typedef domain'\n") ; }
422
423      type_struct = get_type_entry( tokens[ FIELD_OF ] ) ;
424      if ( type_struct == NULL ) 
425      { 
426        type_struct = new_node( TYPE ) ;
427        strcpy( type_struct->name, tokens[FIELD_OF] ) ;
428        type_struct->type_type = DERIVED ;
429        add_node_to_end( type_struct , &Type ) ;
430      }
431
432      if        ( defining_i1_field )      {
433        field_struct = new_node( I1 ) ;
434      } else if ( defining_rconfig_field ) {
435        field_struct = new_node( RCONFIG ) ;
436      } else {
437        field_struct = new_node( FIELD ) ;
438      }
439
440      strcpy( field_struct->name, tokens[FIELD_SYM] ) ;
441
442      if ( set_state_type( tokens[FIELD_TYPE], field_struct ) )
443       { fprintf(stderr,"Registry warning: type %s used before defined \n",tokens[FIELD_TYPE] ) ; }
444
445      if ( set_state_dims( tokens[FIELD_DIMS], field_struct ) )
446       { fprintf(stderr,"Registry warning: some problem with dimstring %s\n", tokens[FIELD_DIMS] ) ; }
447
448      if ( strcmp( tokens[FIELD_NTL], "-" ) ) /* that is, if not equal "-" */
449       { field_struct->ntl = atoi(tokens[FIELD_NTL]) ; }
450      field_struct->ntl = ( field_struct->ntl > 0 )?field_struct->ntl:1 ;
451      /* calculate the maximum number of time levels and store in global variable */
452      if ( field_struct->ntl > max_time_level && field_struct->ntl <= 3 ) max_time_level = field_struct->ntl ;
453
454      field_struct->stag_x = 0 ; field_struct->stag_y = 0 ; field_struct->stag_z = 0 ;
455      for ( i = 0 ; i < strlen(tokens[FIELD_STAG]) ; i++ )
456      {
457        if ( tolower(tokens[FIELD_STAG][i]) == 'x' || sw_all_x_staggered ) field_struct->stag_x = 1 ;
458        if ( tolower(tokens[FIELD_STAG][i]) == 'y' || sw_all_y_staggered ) field_struct->stag_y = 1 ;
459        if ( tolower(tokens[FIELD_STAG][i]) == 'z' ) field_struct->stag_z = 1 ;
460      }
461
462      field_struct->restart  = 0 ; field_struct->boundary  = 0 ;
463      for ( i = 0 ; i < MAX_STREAMS ; i++ ) { 
464        reset_mask( field_struct->io_mask, i ) ;
465      }
466
467      {
468        char prev = '\0' ;
469        char x ;
470        char tmp[NAMELEN], tmp1[NAMELEN], tmp2[NAMELEN] ;
471        int len_of_tok ;
472        char fcn_name[2048], aux_fields[2048] ;
473
474        strcpy(tmp,tokens[FIELD_IO]) ;
475        if (( p = index(tmp,'=') ) != NULL ) { *p = '\0' ; }
476        for ( i = 0 ; i < strlen(tmp) ; i++ )
477        {
478          x = tolower(tmp[i]) ;
479          if ( x == 'h' || x == 'i' ) {
480            char c, *p, *pp ;
481            int unitid ;
482            int stream ;
483            unsigned int * mask ;
484            stream = ( x == 'h' )?HISTORY_STREAM:INPUT_STREAM ;
485            mask = field_struct->io_mask ;
486            set_mask( mask , stream ) ;
487            strcpy(tmp1, &(tmp[++i])) ;
488            for ( p = tmp1  ; *p ; i++, p++ ) { 
489              c = tolower(*p) ; if ( c >= 'a' && c <= 'z' ) { *p = '\0' ; i-- ; break ; }
490              reset_mask( mask , stream ) ;
491            }
492            for ( p = tmp1  ; *p ; p++ ) { 
493              x = *p ;
494              if ( x >= '0' && x <= '9' ) { 
495                set_mask( mask , stream + x - '0' ) ; 
496              }
497              else if ( x == '{' ) {
498                strcpy(tmp2,p+1) ;
499                if (( pp = index(tmp2,'}') ) != NULL ) {
500                  *pp = '\0' ;
501                  unitid = atoi(tmp2) ;  /* JM 20100416 */
502                  if ( unitid >= 0  || unitid < MAX_STREAMS && stream + unitid < MAX_HISTORY ) {
503                    set_mask( mask , stream + unitid   ) ;
504                  }
505                  p = p + strlen(tmp2) + 1 ;
506                } else {
507                  fprintf(stderr,"registry syntax error: unmatched {} in the io string for definition of %s\n",tokens[FIELD_SYM]) ;
508                  exit(9) ;
509                }
510              }
511            }
512          }
513        }
514
515        for ( i = 0 ; i < (len_of_tok = strlen(tokens[FIELD_IO])) ; i++ )
516        {
517          int unitid = -1 ;
518          x = tolower(tokens[FIELD_IO][i]) ;
519          if ( x == '{' ) {
520            int ii,iii ;
521            char * pp ;
522            char tmp[NAMELEN] ;
523            strcpy(tmp,tokens[FIELD_IO]) ;   
524
525            if (( pp = index(tmp,'}') ) != NULL ) {
526              *pp = '\0' ;
527              iii = pp - (tmp + i + 1) ;
528              unitid = atoi(tmp+i+1) ;  /* JM 20091102 */
529              if ( unitid >= 0  || unitid < MAX_STREAMS  && unitid < MAX_HISTORY ) {
530                if        ( prev == 'i' ) {
531                  set_mask( field_struct->io_mask , unitid + MAX_HISTORY  ) ;
532                } else if ( prev == 'h' ) {
533                  set_mask( field_struct->io_mask , unitid   ) ;
534                }
535              }
536              i += iii ;
537              continue ;
538            } else {
539              fprintf(stderr,"registry syntax error: unmatched {} in the io string for definition of %s\n",tokens[FIELD_SYM]) ;
540              exit(9) ;
541            }
542
543          } else if ( x >= 'a' && x <= 'z' ) {
544            if ( x == 'r' ) { field_struct->restart = 1 ; set_mask( field_struct->io_mask , RESTART_STREAM   ) ; }
545            if ( x == 'b' ) { field_struct->boundary  = 1 ; set_mask( field_struct->io_mask , BOUNDARY_STREAM   ) ; }
546            if ( x == 'f' || x == 'd' || x == 'u' || x == 's' ) { 
547                               strcpy(aux_fields,"") ;
548                               strcpy(fcn_name,"") ; 
549                               if ( tokens[FIELD_IO][i+1] == '(' )     /* catch a possible error */
550                               {
551                                 fprintf(stderr,
552                                    "Registry warning: syntax error in %c specifier of IO field for %s\n",x,tokens[FIELD_SYM]) ;
553                                 fprintf(stderr,
554                                    "                  equal sign needed before left paren\n") ;
555                               }
556
557                               if ( tokens[FIELD_IO][i+1] == '=' ) 
558                               {
559                                 int ii, jj, state ;
560                                 state = 0 ;
561                                 jj = 0 ;
562                                 for ( ii = i+3 ; ii < len_of_tok ; ii++ )
563                                 {
564                                   if ( tokens[FIELD_IO][ii] == ')' ) { if (state == 0 )fcn_name[jj] = '\0' ; aux_fields[jj] = '\0' ; break ; }
565                                   if ( tokens[FIELD_IO][ii] == ':' ) { fcn_name[jj] = '\0' ; jj= 0 ; state++ ; continue ;}
566                                   if ( tokens[FIELD_IO][ii] == ',' && state == 0 ) {
567                                     fprintf(stderr,
568                                             "Registry warning: syntax error in %c specifier of IO field for %s\n",x,
569                                             tokens[FIELD_SYM]) ;
570                                   }
571                                   if ( state == 0 )  /* looking for interpolation fcn name */
572                                   {
573                                     fcn_name[jj++] = tokens[FIELD_IO][ii] ;
574                                   }
575                                   if ( state > 0 )
576                                   {
577                                     aux_fields[jj++] = tokens[FIELD_IO][ii] ;
578                                   }
579                                 }
580                                 i = ii ;
581                               }
582                               else
583                               {
584                                 if ( x == 'f' || x == 'd' ) strcpy(fcn_name,"interp_fcn") ;
585                                 if ( x == 'u' ) strcpy(fcn_name,"copy_fcn") ;
586                                 if ( x == 's' ) strcpy(fcn_name,"smoother") ;
587                               }
588                               if      ( x == 'f' )  { 
589                                 field_struct->nest_mask |= FORCE_DOWN ; 
590                                 strcpy(field_struct->force_fcn_name, fcn_name ) ;
591                                 strcpy(field_struct->force_aux_fields, aux_fields ) ;
592                               }
593                               else if ( x == 'd' )  { 
594                                 field_struct->nest_mask |= INTERP_DOWN ; 
595                                 strcpy(field_struct->interpd_fcn_name, fcn_name ) ;
596                                 strcpy(field_struct->interpd_aux_fields, aux_fields ) ;
597                               }
598                               else if ( x == 's' )  { 
599                                 field_struct->nest_mask |= SMOOTH_UP ; 
600                                 strcpy(field_struct->smoothu_fcn_name, fcn_name ) ;
601                                 strcpy(field_struct->smoothu_aux_fields, aux_fields ) ;
602                               }
603                               else if ( x == 'u' )  { 
604                                 field_struct->nest_mask |= INTERP_UP ; 
605                                 strcpy(field_struct->interpu_fcn_name, fcn_name ) ;
606                                 strcpy(field_struct->interpu_aux_fields, aux_fields ) ;
607                               }
608            }
609            prev = x ;
610          }
611        }
612      }
613
614      field_struct->dname[0] = '\0' ;
615      if ( strcmp( tokens[FIELD_DNAME], "-" ) ) /* that is, if not equal "-" */
616        { strcpy( field_struct->dname , tokens[FIELD_DNAME] ) ; }
617      strcpy(field_struct->descrip,"-") ;
618      if ( strcmp( tokens[FIELD_DESCRIP], "-" ) ) /* that is, if not equal "-" */
619        { strcpy( field_struct->descrip , tokens[FIELD_DESCRIP] ) ; }
620      strcpy(field_struct->units,"-") ;
621      if ( strcmp( tokens[FIELD_UNITS], "-" ) ) /* that is, if not equal "-" */
622        { strcpy( field_struct->units , tokens[FIELD_UNITS] ) ; }
623      strcpy(field_struct->use,"-") ;
624      if ( strcmp( tokens[FIELD_USE], "-" ) ) /* that is, if not equal "-" */
625        { strcpy( field_struct->use , tokens[FIELD_USE] ) ;
626        }
627
628      /* specific settings for RCONFIG entries */
629      if ( defining_rconfig_field )
630      {
631        if ( strcmp( tokens[RCNF_NENTRIES] , "-" ) ) /* that is, if not equal "-" */
632        {
633          strcpy(field_struct->nentries, tokens[RCNF_NENTRIES] ) ;
634        } else {
635          strcpy(field_struct->nentries, "1" ) ;
636        }
637        if ( strcmp( tokens[RCNF_HOWSET] , "-" ) ) /* that is, if not equal "-" */
638        {
639          strcpy(field_struct->howset,tokens[RCNF_HOWSET]) ;
640        } else {
641          strcpy(field_struct->howset,"") ;
642        }
643        if ( strcmp( tokens[RCNF_DEFAULT] , "-" ) ) /* that is, if not equal "-" */
644        {
645          strcpy(field_struct->dflt,tokens[RCNF_DEFAULT]) ;
646        } else {
647          strcpy(field_struct->dflt,"") ;
648        }
649      }
650
651      if ( field_struct->type != NULL )
652        if ( field_struct->type->type_type == DERIVED && field_struct->ndims > 0 )
653          { fprintf(stderr,"Registry warning: type item %s of type %s can not be multi-dimensional ",
654                           tokens[FIELD_SYM], tokens[FIELD_TYPE] ) ; }
655
656/**/  if ( ! field_struct->scalar_array_member )
657      {
658        add_node_to_end( field_struct , &(type_struct->fields) ) ;
659      }
660/**/  else   /* if ( field_struct->scalar_array_member ) */
661      {
662/*
663   Here we are constructing a list of nodes to represent the list of 4D scalar arrays in the model
664
665   This list is rooted at the FourD pointer.
666   Each array is represented by its own node; each node has a pointer, members, to the list
667   of fields that make it up. 
668
669*/
670        node_t * q , * member  ;
671        if (( q = get_4d_entry(field_struct->use )) == NULL )  /* first instance of a 4d array member */
672        {
673          q = new_node( FOURD ) ;
674          *q = *field_struct ;  /* this overwrites the node */
675          strcpy( q->name, field_struct->use ) ;
676          strcpy( q->use, "" ) ;
677          q->node_kind = FOURD ;
678          q->scalar_array_member = 0 ;
679          q->next4d = NULL ;
680          q->next = NULL ;
681                  /* add 4d q node to the list of fields of this type and also attach
682                     it to the global list of 4d arrays */
683          add_node_to_end( q , &(type_struct->fields) ) ;
684          add_node_to_end_4d( q , &(FourD) ) ;
685        }
686        member = new_node( MEMBER ) ;
687        *member = *q ;
688        member->node_kind = MEMBER ;
689        member->members = NULL ;
690        member->scalar_array_member = 1 ;
691        strcpy( member->name , field_struct->name ) ;
692        strcpy( member->dname , field_struct->dname ) ;
693        strcpy( member->use , field_struct->use ) ;
694        strcpy( member->descrip , field_struct->descrip ) ;
695        strcpy( member->units , field_struct->units ) ;
696        member->next = NULL ;
697        for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) {
698          member->io_mask[i] = field_struct->io_mask[i] ;
699        }
700        member->nest_mask = field_struct->nest_mask ;
701        member->ndims = field_struct->ndims ;
702        member->restart = field_struct->restart ;
703        member->boundary = field_struct->boundary ;
704        strcpy( member->interpd_fcn_name, field_struct->interpd_fcn_name) ;
705        strcpy( member->interpd_aux_fields,  field_struct->interpd_aux_fields)  ;
706        strcpy( member->interpu_fcn_name, field_struct->interpu_fcn_name) ;
707        strcpy( member->interpu_aux_fields,  field_struct->interpu_aux_fields)  ;
708        strcpy( member->smoothu_fcn_name, field_struct->smoothu_fcn_name) ;
709        strcpy( member->smoothu_aux_fields,  field_struct->smoothu_aux_fields)  ;
710        strcpy( member->force_fcn_name, field_struct->force_fcn_name) ;
711        strcpy( member->force_aux_fields,  field_struct->force_aux_fields)  ;
712        for ( ii = 0 ; ii < member->ndims ; ii++ )
713          member->dims[ii] = field_struct->dims[ii] ;
714        add_node_to_end( member , &(q->members) ) ;
715        free(field_struct) ;  /* We've used all the information about this entry.
716                                 It is not a field but the name of one of the members of
717                                 a 4d field.  we have handled that here. Discard the original node. */
718      }
719    }
720
721/* dimespec entry */
722    else if ( !strcmp( tokens[ TABLE ] , "dimspec" ) )
723    {
724      node_t * dim_struct ;
725      dim_struct = new_node( DIM ) ;
726      if ( get_dim_entry ( tokens[DIM_NAME] ) != NULL )
727        { fprintf(stderr,"Registry warning: dimspec (%s) already defined\n",tokens[DIM_NAME] ) ; }
728      strcpy(dim_struct->dim_name,tokens[DIM_NAME]) ;
729      if ( set_dim_order( tokens[DIM_ORDER], dim_struct ) )
730        { fprintf(stderr,"Registry warning: problem with dimorder (%s)\n",tokens[DIM_ORDER] ) ; }
731      if ( set_dim_len( tokens[DIM_SPEC], dim_struct ) )
732        { fprintf(stderr,"Registry warning: problem with dimspec (%s)\n",tokens[DIM_SPEC] ) ; }
733      if ( set_dim_orient( tokens[DIM_ORIENT], dim_struct ) )
734        { fprintf(stderr,"Registry warning: problem with dimorient (%s)\n",tokens[DIM_ORIENT] ) ; }
735      if ( strcmp( tokens[DIM_DATA_NAME], "-" ) ) /* that is, if not equal "-" */
736        { strcpy( dim_struct->dim_data_name , tokens[DIM_DATA_NAME] ) ; }
737
738      add_node_to_end( dim_struct , &Dim ) ;
739    }
740
741/* package */
742    else if ( !strcmp( tokens[ TABLE ] , "package" ) )
743    {
744      node_t * package_struct ;
745      package_struct = new_node( PACKAGE ) ;
746      strcpy( package_struct->name          , tokens[PKG_SYM]       ) ;
747      strcpy( package_struct->pkg_assoc     , tokens[PKG_ASSOC]     ) ;
748      strcpy( package_struct->pkg_statevars , tokens[PKG_STATEVARS] ) ;
749      strcpy( package_struct->pkg_4dscalars , tokens[PKG_4DSCALARS] ) ;
750
751      add_node_to_end( package_struct , &Packages ) ;
752    }
753
754/* halo, period, xpose */
755    else if ( !strcmp( tokens[ TABLE ] , "halo" ) )
756    {
757      node_t * comm_struct ;
758      comm_struct = new_node( HALO ) ;
759      strcpy( comm_struct->name        , tokens[COMM_ID]     ) ;
760      strcpy( comm_struct->use         , tokens[COMM_USE]     ) ;
761#if 1
762      for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ )  {
763        for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
764      } 
765#else
766      strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
767#endif
768      add_node_to_end( comm_struct , &Halos ) ;
769    }
770    else if ( !strcmp( tokens[ TABLE ] , "period" ) )
771    {
772      node_t * comm_struct ;
773      comm_struct = new_node( PERIOD ) ;
774      strcpy( comm_struct->name        , tokens[COMM_ID]     ) ;
775      strcpy( comm_struct->use         , tokens[COMM_USE]     ) ;
776#if 1
777      for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ )  {
778        for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
779      } 
780#else
781      strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
782#endif
783      add_node_to_end( comm_struct , &Periods ) ;
784    }
785    else if ( !strcmp( tokens[ TABLE ] , "xpose" ) )
786    {
787      node_t * comm_struct ;
788      comm_struct = new_node( XPOSE ) ;
789      strcpy( comm_struct->name        , tokens[COMM_ID]     ) ;
790      strcpy( comm_struct->use         , tokens[COMM_USE]     ) ;
791#if 1
792      for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ )  {
793        for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
794      } 
795#else
796      strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
797#endif
798      add_node_to_end( comm_struct , &Xposes ) ;
799    }
800    else if ( !strcmp( tokens[ TABLE ] , "swap" ) )
801    {
802      node_t * comm_struct ;
803      comm_struct = new_node( SWAP ) ;
804      strcpy( comm_struct->name        , tokens[COMM_ID]     ) ;
805      strcpy( comm_struct->use         , tokens[COMM_USE]     ) ;
806#if 1
807      for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ )  {
808        for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
809      }
810#else
811      strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
812#endif
813      add_node_to_end( comm_struct , &Swaps ) ;
814    }
815    else if ( !strcmp( tokens[ TABLE ] , "cycle" ) )
816    {
817      node_t * comm_struct ;
818      comm_struct = new_node( CYCLE ) ;
819      strcpy( comm_struct->name        , tokens[COMM_ID]     ) ;
820      strcpy( comm_struct->use         , tokens[COMM_USE]     ) ;
821#if 1
822      for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ )  {
823        for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
824      }
825#else
826      strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
827#endif
828      add_node_to_end( comm_struct , &Cycles ) ;
829    }
830
831
832#if 0
833     fprintf(stderr,"vvvvvvvvvvvvvvvvvvvvvvvvvvv\n") ;
834     show_nodelist( Type ) ;
835     fprintf(stderr,"^^^^^^^^^^^^^^^^^^^^^^^^^^^\n") ;
836#endif
837     parseline[0] = '\0' ;  /* reset parseline */
838  }
839
840  Domain = *(get_type_entry( "domain" )) ;
841
842#if 0
843  show_node( &Domain ) ;
844#endif
845
846  return(0) ;
847
848}
849
850node_t *
851get_dim_entry( char *s )
852{
853  node_t * p ;
854  for ( p = Dim ; p != NULL ; p = p->next )
855  {
856    if ( !strcmp(p->dim_name, s ) ) {
857      return( p ) ;
858    }
859  }
860  return(NULL) ;
861}
862
863int
864set_state_type( char * typename, node_t * state_entry )
865{
866  if ( typename == NULL ) return(1) ;
867  return (( state_entry->type = get_type_entry( typename )) == NULL )  ;
868}
869
870int
871set_dim_len ( char * dimspec , node_t * dim_entry )
872{
873  if      (!strcmp( dimspec , "standard_domain" ))
874   { dim_entry->len_defined_how = DOMAIN_STANDARD ; }
875  else if (!strncmp( dimspec, "constant=" , 9 ))
876  {
877    char *p, *colon, *paren ;
878    p = &(dimspec[9]) ;
879    /* check for colon */
880    if (( colon = index(p,':')) != NULL )
881    {
882      *colon = '\0' ;
883      if (( paren = index(p,'(')) !=NULL )
884      {
885        dim_entry->coord_start = atoi(paren+1) ;
886      }
887      else
888      {
889        fprintf(stderr,"WARNING: illegal syntax (missing opening paren) for constant: %s\n",p) ;
890      }
891      dim_entry->coord_end   = atoi(colon+1) ;
892    }
893    else
894    {
895      dim_entry->coord_start = 1 ;
896      dim_entry->coord_end   = atoi(p) ;
897    }
898    dim_entry->len_defined_how = CONSTANT ;
899  }
900  else if (!strncmp( dimspec, "namelist=", 9 ))
901  {
902    char *p, *colon ;
903
904    p = &(dimspec[9]) ;
905    /* check for colon */
906    if (( colon = index(p,':')) != NULL )
907    {
908      *colon = '\0' ;
909      strcpy( dim_entry->assoc_nl_var_s, p ) ;
910      strcpy( dim_entry->assoc_nl_var_e, colon+1 ) ;
911    }
912    else
913    {
914      strcpy( dim_entry->assoc_nl_var_s, "1" ) ;
915      strcpy( dim_entry->assoc_nl_var_e, p ) ;
916    }
917    dim_entry->len_defined_how = NAMELIST ;
918  }
919  else
920  {
921    return(1) ;
922  }
923  return(0) ;
924}
925
926int
927set_dim_orient ( char * dimorient , node_t * dim_entry )
928{
929  if      (!strcmp( dimorient , "x" ))
930   { dim_entry->coord_axis = COORD_X ; }
931  else if (!strcmp( dimorient , "y" )) 
932   { dim_entry->coord_axis = COORD_Y ; }
933  else if (!strcmp( dimorient , "z" )) 
934   { dim_entry->coord_axis = COORD_Z ; }
935  else
936   { dim_entry->coord_axis = COORD_C ; }
937  return(0) ;
938}
939
940/* integrity checking of dimension list; make sure that
941   namelist specified dimensions have an associated namelist variable */
942int
943check_dimspecs()
944{
945  node_t * p, *q ;
946  int ord ;
947
948  for ( p = Dim ; p != NULL ; p = p->next )
949  {
950    if      ( p->len_defined_how == DOMAIN_STANDARD )
951    {
952      if ( p->dim_order < 1 || p->dim_order > 3 )
953      {
954        fprintf(stderr,"WARNING: illegal dim order %d for dimspec %s\n",p->dim_order,p->name) ;
955      }
956      ord = p->dim_order-1 ;
957      if ( model_order[ord] != p->coord_axis )
958      {
959        if ( model_order[ord] == -1 ) model_order[ord] = p->coord_axis ;
960        else
961        {
962          fprintf(stderr,"WARNING: coord-axis/dim-order for dimspec %s is inconsistent with previous dimspec.\n",p->name) ;
963        }
964      }
965    }
966    else if ( p->len_defined_how == NAMELIST )
967    {
968      if ( strcmp( p->assoc_nl_var_s, "1" ) )   /* if not equal to "1" */
969      {
970        if (( q = get_entry(p->assoc_nl_var_s,Domain.fields)) == NULL )
971        {
972          fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n",
973                  p->assoc_nl_var_s,p->name ) ;
974          return(1) ;
975        }
976        if ( ! q->node_kind & RCONFIG )
977        {
978          fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n",
979                  p->assoc_nl_var_s,p->name ) ;
980          return(1) ;
981        }
982        if ( strcmp( q->type->name , "integer" ) )   /* if not integer */
983        {
984          fprintf(stderr,"WARNING: namelist variable %s must be an integer if used to define dimension %s\n",
985                  p->assoc_nl_var_s,p->name ) ;
986          return(1) ;
987        }
988        if ( strcmp( q->nentries , "1" ) )   /* if not 1 entry */
989        {
990          fprintf(stderr,"WARNING: namelist variable %s must have only one entry if used to define dimension %s\n",
991                  p->assoc_nl_var_s,p->name ) ;
992          return(1) ;
993        }
994      }
995      if (( q = get_entry(p->assoc_nl_var_e,Domain.fields)) == NULL )
996      {
997        fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n",
998                p->assoc_nl_var_e,p->name ) ;
999        return(1) ;
1000      }
1001      if ( ! q->node_kind & RCONFIG )
1002      {
1003        fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n",
1004                p->assoc_nl_var_e,p->name ) ;
1005        return(1) ;
1006      }
1007      if ( strcmp( q->type->name , "integer" ) )   /* if not integer */
1008      {
1009        fprintf(stderr,"WARNING: namelist variable %s must be an integer if used to define dimension %s\n",
1010                p->assoc_nl_var_e,p->name ) ;
1011        return(1) ;
1012      }
1013      if ( strcmp( q->nentries , "1" ) )   /* if not 1 entry */
1014      {
1015        fprintf(stderr,"WARNING: namelist variable %s must have only one entry if used to define dimension %s\n",
1016                p->assoc_nl_var_e,p->name ) ;
1017        return(1) ;
1018      }
1019    }
1020  }
1021  return(0) ;
1022}
1023
1024int
1025set_dim_order ( char * dimorder , node_t * dim_entry )
1026{
1027  dim_entry->dim_order = atoi(dimorder) ;
1028  return(0) ;
1029}
1030
1031int
1032init_parser()
1033{
1034  model_order[0] = -1 ;
1035  model_order[1] = -1 ;
1036  model_order[2] = -1 ;
1037  return(0) ;
1038}
Note: See TracBrowser for help on using the repository browser.