?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Add comments to old c preproc / m4 processing since gfortran is unable to
[WRF.git] / tools / reg_parse.c
blob01176c0ea4f086e9e239f758570d1eade59702f5
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
87 static int ntracers = 0 ;
88 static char tracers[1000][100] ;
89
90 int
91 pre_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 }
294 /* otherwise output the line as is */
295 fprintf(outfile,"%s\n",parseline_save) ;
296 parseline[0] = '\0' ; /* reset parseline */
297 }
298 return(retval) ;
299 }
300
301 int
302 reg_parse( FILE * infile )
303 {
304 /* Had to increase size for SOA from 4096 to 7000, Manish Shrivastava 2010 */
305 char inln[7000], parseline[7000] ;
306 char *p, *q ;
307 char *tokens[MAXTOKENS], *toktmp[MAXTOKENS] ;
308 int i, ii, idim ;
309 int defining_state_field, defining_rconfig_field, defining_i1_field ;
310
311 parseline[0] = '\0' ;
312
313 max_time_level = 1 ;
314
315 /* main parse loop over registry lines */
316 /* Had to increase size for SOA from 4096 to 7000, Manish Shrivastava 2010 */
317 while ( fgets ( inln , 7000 , infile ) != NULL )
318 {
319 strcat( parseline , inln ) ;
320 /* allow \ to continue the end of a line */
321 if (( p = index( parseline, '\\' )) != NULL )
322 {
323 if ( *(p+1) == '\n' || *(p+1) == '\0' )
324 {
325 *p = '\0' ;
326 continue ; /* go get another line */
327 }
328 }
329
330 make_lower( parseline ) ;
331 if (( p = index( parseline , '#' )) != NULL ) *p = '\0' ; /* discard comments (dont worry about quotes for now) */
332 if (( p = index( parseline , '\n' )) != NULL ) *p = '\0' ; /* discard newlines */
333 for ( i = 0 ; i < MAXTOKENS ; i++ ) tokens[i] = NULL ;
334 i = 0 ;
335
336 if ((tokens[i] = my_strtok(parseline)) != NULL ) i++ ;
337
338 while (( tokens[i] = my_strtok(NULL) ) != NULL && i < MAXTOKENS ) i++ ;
339 if ( i <= 0 ) continue ;
340
341 for ( i = 0 ; i < MAXTOKENS ; i++ )
342 {
343 if ( tokens[i] == NULL ) tokens[i] = "-" ;
344 }
345
346 /* remove quotes from quoted entries */
347 for ( i = 0 ; i < MAXTOKENS ; i++ )
348 {
349 char * pp ;
350 if ( tokens[i][0] == '"' ) tokens[i]++ ;
351 if ((pp=rindex( tokens[i], '"' )) != NULL ) *pp = '\0' ;
352 }
353
354 defining_state_field = 0 ;
355 defining_rconfig_field = 0 ;
356 defining_i1_field = 0 ;
357
358 /* state entry */
359 if ( !strcmp( tokens[ TABLE ] , "state" ) )
360 {
361 /* turn a state entry into a typedef to define a field in the top-level built-in type domain */
362 tokens[TABLE] = "typedef" ;
363 for ( i = MAXTOKENS-1 ; i >= 2 ; i-- ) tokens[i] = tokens[i-1] ; /* shift the fields to the left */
364 tokens[FIELD_OF] = "domain" ;
365 if ( !strcmp( tokens[FIELD_TYPE], "double" ) ) tokens[FIELD_TYPE] = "doubleprecision" ;
366 defining_state_field = 1 ;
367 }
368 if ( !strcmp( tokens[ TABLE ] , "rconfig" ) )
369 {
370
371 char *pp, value[256] ;
372 for ( pp = tokens[RCNF_SYM_PRE] ; (*pp == ' ' || *pp == ' ') && *pp ; pp++ ) ;
373 sprintf(value, "RCONFIG_%s" ,pp) ;
374 if ( sym_get(value) == NULL ) {
375 sym_add(value) ;
376 } else {
377 parseline[0] = '\0' ; /* reset parseline */
378 continue ;
379 }
380
381 /* turn a rconfig entry into a typedef to define a field in the top-level built-in type domain */
382 for ( i = 0 ; i < MAXTOKENS ; i++ ) { toktmp[i] = tokens[i] ; tokens[i] = "-" ; }
383 tokens[TABLE] = "typedef" ;
384 tokens[FIELD_OF] = "domain" ;
385 tokens[RCNF_TYPE] = toktmp[RCNF_TYPE_PRE] ;
386 if ( !strcmp( tokens[RCNF_TYPE], "double" ) ) tokens[RCNF_TYPE] = "doubleprecision" ;
387 tokens[RCNF_SYM] = toktmp[RCNF_SYM_PRE] ;
388 tokens[RCNF_IO] = toktmp[RCNF_IO_PRE] ;
389 tokens[RCNF_DNAME] = toktmp[RCNF_DNAME_PRE] ;
390 tokens[RCNF_USE] = "-" ;
391 tokens[RCNF_DESCRIP] = toktmp[RCNF_DESCRIP_PRE] ;
392 tokens[RCNF_UNITS] = toktmp[RCNF_UNITS_PRE] ;
393 tokens[RCNF_HOWSET] = toktmp[RCNF_HOWSET_PRE] ;
394 tokens[RCNF_NENTRIES] = toktmp[RCNF_NENTRIES_PRE] ;
395 tokens[RCNF_DEFAULT] = toktmp[RCNF_DEFAULT_PRE] ;
396 defining_rconfig_field = 1 ;
397 }
398 if ( !strcmp( tokens[ TABLE ] , "i1" ) )
399 {
400 /* turn a state entry into a typedef to define a field in
401 the top-level built-in type domain */
402 tokens[TABLE] = "typedef" ;
403 /* shift the fields to the left */
404 for ( i = MAXTOKENS-1 ; i >= 2 ; i-- ) tokens[i] = tokens[i-1] ;
405 tokens[FIELD_OF] = "domain" ;
406 if ( !strcmp( tokens[FIELD_TYPE], "double" ) ) tokens[FIELD_TYPE] = "doubleprecision" ;
407 defining_i1_field = 1 ;
408 }
409
410 /* NOTE: fall through */
411
412 /* typedef entry */
413 if ( !strcmp( tokens[ TABLE ] , "typedef" ) )
414 {
415 node_t * field_struct ;
416 node_t * type_struct ;
417
418 if ( !defining_state_field && ! defining_i1_field &&
419 !defining_rconfig_field && !strcmp(tokens[FIELD_OF],"domain") )
420 { fprintf(stderr,"Registry warning: 'domain' is a reserved registry type name. Cannot 'typedef domain'\n") ; }
421
422 type_struct = get_type_entry( tokens[ FIELD_OF ] ) ;
423 if ( type_struct == NULL )
424 {
425 type_struct = new_node( TYPE ) ;
426 strcpy( type_struct->name, tokens[FIELD_OF] ) ;
427 type_struct->type_type = DERIVED ;
428 add_node_to_end( type_struct , &Type ) ;
429 }
430
431 if ( defining_i1_field ) {
432 field_struct = new_node( I1 ) ;
433 } else if ( defining_rconfig_field ) {
434 field_struct = new_node( RCONFIG ) ;
435 } else {
436 field_struct = new_node( FIELD ) ;
437 }
438
439 strcpy( field_struct->name, tokens[FIELD_SYM] ) ;
440
441 if ( set_state_type( tokens[FIELD_TYPE], field_struct ) )
442 { fprintf(stderr,"Registry warning: type %s used before defined \n",tokens[FIELD_TYPE] ) ; }
443
444 if ( set_state_dims( tokens[FIELD_DIMS], field_struct ) )
445 { fprintf(stderr,"Registry warning: some problem with dimstring %s\n", tokens[FIELD_DIMS] ) ; }
446
447 if ( strcmp( tokens[FIELD_NTL], "-" ) ) /* that is, if not equal "-" */
448 { field_struct->ntl = atoi(tokens[FIELD_NTL]) ; }
449 field_struct->ntl = ( field_struct->ntl > 0 )?field_struct->ntl:1 ;
450 /* calculate the maximum number of time levels and store in global variable */
451 if ( field_struct->ntl > max_time_level && field_struct->ntl <= 3 ) max_time_level = field_struct->ntl ;
452
453 field_struct->stag_x = 0 ; field_struct->stag_y = 0 ; field_struct->stag_z = 0 ;
454 field_struct->mp_var = 0 ; field_struct->nmm_v_grid=0 ; field_struct->full_feedback = 0;
455 field_struct->no_feedback = 0;
456 for ( i = 0 ; i < strlen(tokens[FIELD_STAG]) ; i++ )
457 {
458 if ( tolower(tokens[FIELD_STAG][i]) == 'x' || sw_all_x_staggered ) field_struct->stag_x = 1 ;
459 if ( tolower(tokens[FIELD_STAG][i]) == 'y' || sw_all_y_staggered ) field_struct->stag_y = 1 ;
460 if ( tolower(tokens[FIELD_STAG][i]) == 'z' ) field_struct->stag_z = 1 ;
461 if ( tolower(tokens[FIELD_STAG][i]) == 'v' )
462 field_struct->nmm_v_grid = 1 ;
463 if ( tolower(tokens[FIELD_STAG][i]) == 'm' )
464 field_struct->mp_var = 1;
465 if ( tolower(tokens[FIELD_STAG][i]) == 'f' )
466 field_struct->full_feedback = 1;
467 if ( tolower(tokens[FIELD_STAG][i]) == 'n' )
468 field_struct->no_feedback = 1;
469 }
470
471 field_struct->restart = 0 ; field_struct->boundary = 0 ;
472 for ( i = 0 ; i < MAX_STREAMS ; i++ ) {
473 reset_mask( field_struct->io_mask, i ) ;
474 }
475
476 {
477 char prev = '\0' ;
478 char x ;
479 char tmp[NAMELEN], tmp1[NAMELEN], tmp2[NAMELEN] ;
480 int len_of_tok ;
481 char fcn_name[2048], aux_fields[2048] ;
482
483 strcpy(tmp,tokens[FIELD_IO]) ;
484 if (( p = index(tmp,'=') ) != NULL ) { *p = '\0' ; }
485 for ( i = 0 ; i < strlen(tmp) ; i++ )
486 {
487 x = tolower(tmp[i]) ;
488 if ( x == 'h' || x == 'i' ) {
489 char c, *p, *pp ;
490 int unitid ;
491 int stream ;
492 unsigned int * mask ;
493 stream = ( x == 'h' )?HISTORY_STREAM:INPUT_STREAM ;
494 mask = field_struct->io_mask ;
495 set_mask( mask , stream ) ;
496 strcpy(tmp1, &(tmp[++i])) ;
497 for ( p = tmp1 ; *p ; i++, p++ ) {
498 c = tolower(*p) ; if ( c >= 'a' && c <= 'z' ) { *p = '\0' ; i-- ; break ; }
499 reset_mask( mask , stream ) ;
500 }
501 for ( p = tmp1 ; *p ; p++ ) {
502 x = *p ;
503 if ( x >= '0' && x <= '9' ) {
504 set_mask( mask , stream + x - '0' ) ;
505 }
506 else if ( x == '{' ) {
507 strcpy(tmp2,p+1) ;
508 if (( pp = index(tmp2,'}') ) != NULL ) {
509 *pp = '\0' ;
510 unitid = atoi(tmp2) ; /* JM 20100416 */
511 if ( unitid >= 0 || unitid < MAX_STREAMS && stream + unitid < MAX_HISTORY ) {
512 set_mask( mask , stream + unitid ) ;
513 }
514 p = p + strlen(tmp2) + 1 ;
515 } else {
516 fprintf(stderr,"registry syntax error: unmatched {} in the io string for definition of %s\n",tokens[FIELD_SYM]) ;
517 exit(9) ;
518 }
519 }
520 }
521 }
522 }
523
524 for ( i = 0 ; i < (len_of_tok = strlen(tokens[FIELD_IO])) ; i++ )
525 {
526 int unitid = -1 ;
527 x = tolower(tokens[FIELD_IO][i]) ;
528 if ( x == '{' ) {
529 int ii,iii ;
530 char * pp ;
531 char tmp[NAMELEN] ;
532 strcpy(tmp,tokens[FIELD_IO]) ;
533
534 if (( pp = index(tmp,'}') ) != NULL ) {
535 *pp = '\0' ;
536 iii = pp - (tmp + i + 1) ;
537 unitid = atoi(tmp+i+1) ; /* JM 20091102 */
538 if ( unitid >= 0 || unitid < MAX_STREAMS && unitid < MAX_HISTORY ) {
539 if ( prev == 'i' ) {
540 set_mask( field_struct->io_mask , unitid + MAX_HISTORY ) ;
541 } else if ( prev == 'h' ) {
542 set_mask( field_struct->io_mask , unitid ) ;
543 }
544 }
545 /* avoid infinite loop. iii can go negative if the '}' is at the end of the line. */
546 if ( iii > 0 ) i += iii ;
547 continue ;
548 } else {
549 fprintf(stderr,"registry syntax error: unmatched {} in the io string for definition of %s\n",tokens[FIELD_SYM]) ;
550 exit(9) ;
551 }
552
553 } else if ( x >= 'a' && x <= 'z' ) {
554 if ( x == 'r' ) { field_struct->restart = 1 ; set_mask( field_struct->io_mask , RESTART_STREAM ) ; }
555 if ( x == 'b' ) { field_struct->boundary = 1 ; set_mask( field_struct->io_mask , BOUNDARY_STREAM ) ; }
556 if ( x == 'f' || x == 'd' || x == 'u' || x == 's' ) {
557 strcpy(aux_fields,"") ;
558 strcpy(fcn_name,"") ;
559 if ( tokens[FIELD_IO][i+1] == '(' ) /* catch a possible error */
560 {
561 fprintf(stderr,
562 "Registry warning: syntax error in %c specifier of IO field for %s\n",x,tokens[FIELD_SYM]) ;
563 fprintf(stderr,
564 " equal sign needed before left paren\n") ;
565 }
566
567 if ( tokens[FIELD_IO][i+1] == '=' )
568 {
569 int ii, jj, state ;
570 state = 0 ;
571 jj = 0 ;
572 for ( ii = i+3 ; ii < len_of_tok ; ii++ )
573 {
574 if ( tokens[FIELD_IO][ii] == ')' ) { if (state == 0 )fcn_name[jj] = '\0' ; aux_fields[jj] = '\0' ; break ; }
575 if ( tokens[FIELD_IO][ii] == ':' ) { fcn_name[jj] = '\0' ; jj= 0 ; state++ ; continue ;}
576 if ( tokens[FIELD_IO][ii] == ',' && state == 0 ) {
577 fprintf(stderr,
578 "Registry warning: syntax error in %c specifier of IO field for %s\n",x,
579 tokens[FIELD_SYM]) ;
580 }
581 if ( state == 0 ) /* looking for interpolation fcn name */
582 {
583 fcn_name[jj++] = tokens[FIELD_IO][ii] ;
584 }
585 if ( state > 0 )
586 {
587 aux_fields[jj++] = tokens[FIELD_IO][ii] ;
588 }
589 }
590 i = ii ;
591 }
592 else
593 {
594 #if NMM_CORE==1
595 int found_interp=0;
596 if(field_struct->type && field_struct->type->name
597 && (x=='f'||x=='d'||x=='u'||x=='s')) {
598 if(dims_ij_inner(field_struct)) {
599 if(x=='u') {
600 if(!strcasecmp(field_struct->type->name,"real"))
601 found_interp=!!strcpy(fcn_name,"UpCopy");
602 else if(!strcasecmp(field_struct->type->name,"integer"))
603 found_interp=!!strcpy(fcn_name,"UpINear");
604 } else if(x=='d') {
605 if(!strcasecmp(field_struct->type->name,"real"))
606 found_interp=!!strcpy(fcn_name,"DownCopy");
607 else if(!strcasecmp(field_struct->type->name,"integer"))
608 found_interp=!!strcpy(fcn_name,"DownINear");
609 } else if(x=='f') {
610 if(!strcasecmp(field_struct->type->name,"real"))
611 found_interp=!!strcpy(fcn_name,"BdyCopy");
612 else if(!strcasecmp(field_struct->type->name,"integer"))
613 found_interp=!!strcpy(fcn_name,"BdyINear");
614 } else if(x=='s') {
615 if(!strcasecmp(field_struct->type->name,"real"))
616 found_interp=!!strcpy(fcn_name,"nmm_smoother_ijk");
617 }
618 } else if(dims_ikj_inner(field_struct)) {
619 if(x=='d') {
620 if(!strcasecmp(field_struct->type->name,"real"))
621 found_interp=!!strcpy(fcn_name,"DownNearIKJ");
622 } else if(x=='s') {
623 if(!strcasecmp(field_struct->type->name,"real"))
624 found_interp=!!strcpy(fcn_name,"nmm_smoother_ikj");
625 }
626 }
627 }
628 if(!found_interp) {
629 fprintf(stderr,"ERROR: %s %c function invalid. You must specify the function to call in f=, d=, u= or s= when using the NMM cores. The ARW interp functions do not correctly handle the E grid.\n",tokens[FIELD_SYM],x);
630 exit(1);
631 } else {
632 /* warning should no longer be needed
633 fprintf(stderr,"WARNING: %c interpolation unspecified for %s. Using %s.\n",
634 x,tokens[FIELD_SYM],fcn_name);
635 */
636 }
637 #else
638 if ( x == 'f' || x == 'd' ) strcpy(fcn_name,"interp_fcn") ;
639 if ( x == 'u' ) strcpy(fcn_name,"copy_fcn") ;
640 if ( x == 's' ) strcpy(fcn_name,"smoother") ;
641 #endif
642 }
643 #if NMM_CORE==1
644 if(dims_ikj_inner(field_struct) && !strcasestr(fcn_name,"ikj") && !strcasestr(fcn_name,"nointerp")) {
645 fprintf(stderr,"ERROR: %s %c %s: you must use IKJ interpolators for IKJ arrays.\n",
646 tokens[FIELD_SYM],x,fcn_name);
647 exit(1);
648 }
649 if(dims_ij_inner(field_struct) && strcasestr(fcn_name,"ikj") && !strcasestr(fcn_name,"nointerp")) {
650 fprintf(stderr,"ERROR: %s %c %s: you cannot use IKJ interpolators for IJ arrays.\n",
651 tokens[FIELD_SYM],x,fcn_name);
652 exit(1);
653 }
654 #endif
655 if ( x == 'f' ) {
656 field_struct->nest_mask |= FORCE_DOWN ;
657 strcpy(field_struct->force_fcn_name, fcn_name ) ;
658 strcpy(field_struct->force_aux_fields, aux_fields ) ;
659 }
660 else if ( x == 'd' ) {
661 field_struct->nest_mask |= INTERP_DOWN ;
662 strcpy(field_struct->interpd_fcn_name, fcn_name ) ;
663 strcpy(field_struct->interpd_aux_fields, aux_fields ) ;
664 }
665 else if ( x == 's' ) {
666 field_struct->nest_mask |= SMOOTH_UP ;
667 strcpy(field_struct->smoothu_fcn_name, fcn_name ) ;
668 strcpy(field_struct->smoothu_aux_fields, aux_fields ) ;
669 }
670 else if ( x == 'u' ) {
671 field_struct->nest_mask |= INTERP_UP ;
672 strcpy(field_struct->interpu_fcn_name, fcn_name ) ;
673 strcpy(field_struct->interpu_aux_fields, aux_fields ) ;
674 }
675 }
676 prev = x ;
677 }
678 }
679 }
680
681 field_struct->dname[0] = '\0' ;
682 if ( strcmp( tokens[FIELD_DNAME], "-" ) ) /* that is, if not equal "-" */
683 { strcpy( field_struct->dname , tokens[FIELD_DNAME] ) ; }
684 strcpy(field_struct->descrip,"-") ;
685 if ( strcmp( tokens[FIELD_DESCRIP], "-" ) ) /* that is, if not equal "-" */
686 { strcpy( field_struct->descrip , tokens[FIELD_DESCRIP] ) ; }
687 strcpy(field_struct->units,"-") ;
688 if ( strcmp( tokens[FIELD_UNITS], "-" ) ) /* that is, if not equal "-" */
689 { strcpy( field_struct->units , tokens[FIELD_UNITS] ) ; }
690 strcpy(field_struct->use,"-") ;
691 if ( strcmp( tokens[FIELD_USE], "-" ) ) /* that is, if not equal "-" */
692 { strcpy( field_struct->use , tokens[FIELD_USE] ) ;
693 }
694
695 /* specific settings for RCONFIG entries */
696 if ( defining_rconfig_field )
697 {
698 if ( strcmp( tokens[RCNF_NENTRIES] , "-" ) ) /* that is, if not equal "-" */
699 {
700 strcpy(field_struct->nentries, tokens[RCNF_NENTRIES] ) ;
701 } else {
702 strcpy(field_struct->nentries, "1" ) ;
703 }
704 if ( strcmp( tokens[RCNF_HOWSET] , "-" ) ) /* that is, if not equal "-" */
705 {
706 strcpy(field_struct->howset,tokens[RCNF_HOWSET]) ;
707 } else {
708 strcpy(field_struct->howset,"") ;
709 }
710 if ( strcmp( tokens[RCNF_DEFAULT] , "-" ) ) /* that is, if not equal "-" */
711 {
712 strcpy(field_struct->dflt,tokens[RCNF_DEFAULT]) ;
713 } else {
714 strcpy(field_struct->dflt,"") ;
715 }
716 }
717
718 if ( field_struct->type != NULL )
719 if ( field_struct->type->type_type == DERIVED && field_struct->ndims > 0 )
720 { fprintf(stderr,"Registry warning: type item %s of type %s can not be multi-dimensional ",
721 tokens[FIELD_SYM], tokens[FIELD_TYPE] ) ; }
722
723 /**/ if ( ! field_struct->scalar_array_member )
724 {
725 add_node_to_end( field_struct , &(type_struct->fields) ) ;
726 }
727 /**/ else /* if ( field_struct->scalar_array_member ) */
728 {
729 /*
730 Here we are constructing a list of nodes to represent the list of 4D scalar arrays in the model
731
732 This list is rooted at the FourD pointer.
733 Each array is represented by its own node; each node has a pointer, members, to the list
734 of fields that make it up.
735
736 */
737 node_t * q , * member ;
738 if (( q = get_4d_entry(field_struct->use )) == NULL ) /* first instance of a 4d array member */
739 {
740 q = new_node( FOURD ) ;
741 *q = *field_struct ; /* this overwrites the node */
742 strcpy( q->name, field_struct->use ) ;
743 strcpy( q->use, "" ) ;
744 q->node_kind = FOURD ;
745 q->scalar_array_member = 0 ;
746 q->next4d = NULL ;
747 q->next = NULL ;
748 /* add 4d q node to the list of fields of this type and also attach
749 it to the global list of 4d arrays */
750 add_node_to_end( q , &(type_struct->fields) ) ;
751 add_node_to_end_4d( q , &(FourD) ) ;
752 }
753 member = new_node( MEMBER ) ;
754 *member = *q ;
755 member->node_kind = MEMBER ;
756 member->members = NULL ;
757 member->scalar_array_member = 1 ;
758 strcpy( member->name , field_struct->name ) ;
759 strcpy( member->dname , field_struct->dname ) ;
760 strcpy( member->use , field_struct->use ) ;
761 strcpy( member->descrip , field_struct->descrip ) ;
762 strcpy( member->units , field_struct->units ) ;
763 member->next = NULL ;
764 for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) {
765 member->io_mask[i] = field_struct->io_mask[i] ;
766 }
767 member->nest_mask = field_struct->nest_mask ;
768 member->ndims = field_struct->ndims ;
769 member->restart = field_struct->restart ;
770 member->boundary = field_struct->boundary ;
771 strcpy( member->interpd_fcn_name, field_struct->interpd_fcn_name) ;
772 strcpy( member->interpd_aux_fields, field_struct->interpd_aux_fields) ;
773 strcpy( member->interpu_fcn_name, field_struct->interpu_fcn_name) ;
774 strcpy( member->interpu_aux_fields, field_struct->interpu_aux_fields) ;
775 strcpy( member->smoothu_fcn_name, field_struct->smoothu_fcn_name) ;
776 strcpy( member->smoothu_aux_fields, field_struct->smoothu_aux_fields) ;
777 strcpy( member->force_fcn_name, field_struct->force_fcn_name) ;
778 strcpy( member->force_aux_fields, field_struct->force_aux_fields) ;
779 for ( ii = 0 ; ii < member->ndims ; ii++ )
780 member->dims[ii] = field_struct->dims[ii] ;
781 add_node_to_end( member , &(q->members) ) ;
782 free(field_struct) ; /* We've used all the information about this entry.
783 It is not a field but the name of one of the members of
784 a 4d field. we have handled that here. Discard the original node. */
785 }
786 }
787
788 /* dimespec entry */
789 else if ( !strcmp( tokens[ TABLE ] , "dimspec" ) )
790 {
791 node_t * dim_struct ;
792 dim_struct = new_node( DIM ) ;
793 if ( get_dim_entry ( tokens[DIM_NAME] ) != NULL )
794 { fprintf(stderr,"Registry warning: dimspec (%s) already defined\n",tokens[DIM_NAME] ) ; }
795 strcpy(dim_struct->dim_name,tokens[DIM_NAME]) ;
796 if ( set_dim_order( tokens[DIM_ORDER], dim_struct ) )
797 { fprintf(stderr,"Registry warning: problem with dimorder (%s)\n",tokens[DIM_ORDER] ) ; }
798 if ( set_dim_len( tokens[DIM_SPEC], dim_struct ) )
799 { fprintf(stderr,"Registry warning: problem with dimspec (%s)\n",tokens[DIM_SPEC] ) ; }
800 if ( set_dim_orient( tokens[DIM_ORIENT], dim_struct ) )
801 { fprintf(stderr,"Registry warning: problem with dimorient (%s)\n",tokens[DIM_ORIENT] ) ; }
802 if ( strcmp( tokens[DIM_DATA_NAME], "-" ) ) /* that is, if not equal "-" */
803 { strcpy( dim_struct->dim_data_name , tokens[DIM_DATA_NAME] ) ; }
804
805 add_node_to_end( dim_struct , &Dim ) ;
806 }
807
808 /* package */
809 else if ( !strcmp( tokens[ TABLE ] , "package" ) )
810 {
811 node_t * package_struct ;
812 package_struct = new_node( PACKAGE ) ;
813 strcpy( package_struct->name , tokens[PKG_SYM] ) ;
814 strcpy( package_struct->pkg_assoc , tokens[PKG_ASSOC] ) ;
815 strcpy( package_struct->pkg_statevars , tokens[PKG_STATEVARS] ) ;
816 strcpy( package_struct->pkg_4dscalars , tokens[PKG_4DSCALARS] ) ;
817
818 add_node_to_end( package_struct , &Packages ) ;
819 }
820
821 /* halo, period, xpose */
822 else if ( !strcmp( tokens[ TABLE ] , "halo" ) )
823 {
824 node_t * comm_struct ;
825 comm_struct = new_node( HALO ) ;
826 strcpy( comm_struct->name , tokens[COMM_ID] ) ;
827 strcpy( comm_struct->use , tokens[COMM_USE] ) ;
828 #if 1
829 for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) {
830 for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
831 }
832 #else
833 strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
834 #endif
835 add_node_to_end( comm_struct , &Halos ) ;
836 }
837 #if ( WRFPLUS == 1 )
838 else if ( !strcmp( tokens[ TABLE ] , "halo_nta" ) )
839 {
840 node_t * comm_struct ;
841 comm_struct = new_node( HALO_NTA ) ;
842 strcpy( comm_struct->name , tokens[COMM_ID] ) ;
843 strcpy( comm_struct->use , tokens[COMM_USE] ) ;
844 #if 1
845 for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) {
846 for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
847 }
848 #else
849 strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
850 #endif
851 add_node_to_end( comm_struct , &Halos_nta ) ;
852 }
853 #endif
854 else if ( !strcmp( tokens[ TABLE ] , "period" ) )
855 {
856 node_t * comm_struct ;
857 comm_struct = new_node( PERIOD ) ;
858 strcpy( comm_struct->name , tokens[COMM_ID] ) ;
859 strcpy( comm_struct->use , tokens[COMM_USE] ) ;
860 #if 1
861 for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) {
862 for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
863 }
864 #else
865 strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
866 #endif
867 add_node_to_end( comm_struct , &Periods ) ;
868 }
869 else if ( !strcmp( tokens[ TABLE ] , "xpose" ) )
870 {
871 node_t * comm_struct ;
872 comm_struct = new_node( XPOSE ) ;
873 strcpy( comm_struct->name , tokens[COMM_ID] ) ;
874 strcpy( comm_struct->use , tokens[COMM_USE] ) ;
875 #if 1
876 for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) {
877 for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
878 }
879 #else
880 strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
881 #endif
882 add_node_to_end( comm_struct , &Xposes ) ;
883 }
884 else if ( !strcmp( tokens[ TABLE ] , "swap" ) )
885 {
886 node_t * comm_struct ;
887 comm_struct = new_node( SWAP ) ;
888 strcpy( comm_struct->name , tokens[COMM_ID] ) ;
889 strcpy( comm_struct->use , tokens[COMM_USE] ) ;
890 #if 1
891 for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) {
892 for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
893 }
894 #else
895 strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
896 #endif
897 add_node_to_end( comm_struct , &Swaps ) ;
898 }
899 else if ( !strcmp( tokens[ TABLE ] , "cycle" ) )
900 {
901 node_t * comm_struct ;
902 comm_struct = new_node( CYCLE ) ;
903 strcpy( comm_struct->name , tokens[COMM_ID] ) ;
904 strcpy( comm_struct->use , tokens[COMM_USE] ) ;
905 #if 1
906 for ( i = COMM_DEFINE, q=comm_struct->comm_define ; strcmp(tokens[i],"-") ; i++ ) {
907 for(p=tokens[i];*p;p++)if(*p!=' '&&*p!='\t'){*q++=*p;}
908 }
909 #else
910 strcpy( comm_struct->comm_define , tokens[COMM_DEFINE] ) ;
911 #endif
912 add_node_to_end( comm_struct , &Cycles ) ;
913 }
914
915
916 #if 0
917 fprintf(stderr,"vvvvvvvvvvvvvvvvvvvvvvvvvvv\n") ;
918 show_nodelist( Type ) ;
919 fprintf(stderr,"^^^^^^^^^^^^^^^^^^^^^^^^^^^\n") ;
920 #endif
921 parseline[0] = '\0' ; /* reset parseline */
922 }
923
924 Domain = *(get_type_entry( "domain" )) ;
925
926 #if 0
927 show_node( &Domain ) ;
928 #endif
929
930 return(0) ;
931
932 }
933
934 node_t *
935 get_dim_entry( char *s )
936 {
937 node_t * p ;
938 for ( p = Dim ; p != NULL ; p = p->next )
939 {
940 if ( !strcmp(p->dim_name, s ) ) {
941 return( p ) ;
942 }
943 }
944 return(NULL) ;
945 }
946
947 int
948 set_state_type( char * typename, node_t * state_entry )
949 {
950 if ( typename == NULL ) return(1) ;
951 return (( state_entry->type = get_type_entry( typename )) == NULL ) ;
952 }
953
954 int
955 set_dim_len ( char * dimspec , node_t * dim_entry )
956 {
957 if (!strcmp( dimspec , "standard_domain" ))
958 { dim_entry->len_defined_how = DOMAIN_STANDARD ; }
959 else if (!strncmp( dimspec, "constant=" , 9 ))
960 {
961 char *p, *colon, *paren ;
962 p = &(dimspec[9]) ;
963 /* check for colon */
964 if (( colon = index(p,':')) != NULL )
965 {
966 *colon = '\0' ;
967 if (( paren = index(p,'(')) !=NULL )
968 {
969 dim_entry->coord_start = atoi(paren+1) ;
970 }
971 else
972 {
973 fprintf(stderr,"WARNING: illegal syntax (missing opening paren) for constant: %s\n",p) ;
974 }
975 dim_entry->coord_end = atoi(colon+1) ;
976 }
977 else
978 {
979 dim_entry->coord_start = 1 ;
980 dim_entry->coord_end = atoi(p) ;
981 }
982 dim_entry->len_defined_how = CONSTANT ;
983 }
984 else if (!strncmp( dimspec, "namelist=", 9 ))
985 {
986 char *p, *colon ;
987
988 p = &(dimspec[9]) ;
989 /* check for colon */
990 if (( colon = index(p,':')) != NULL )
991 {
992 *colon = '\0' ;
993 strcpy( dim_entry->assoc_nl_var_s, p ) ;
994 strcpy( dim_entry->assoc_nl_var_e, colon+1 ) ;
995 }
996 else
997 {
998 strcpy( dim_entry->assoc_nl_var_s, "1" ) ;
999 strcpy( dim_entry->assoc_nl_var_e, p ) ;
1000 }
1001 dim_entry->len_defined_how = NAMELIST ;
1002 }
1003 else
1004 {
1005 return(1) ;
1006 }
1007 return(0) ;
1008 }
1009
1010 int
1011 set_dim_orient ( char * dimorient , node_t * dim_entry )
1012 {
1013 if (!strcmp( dimorient , "x" ))
1014 { dim_entry->coord_axis = COORD_X ; }
1015 else if (!strcmp( dimorient , "y" ))
1016 { dim_entry->coord_axis = COORD_Y ; }
1017 else if (!strcmp( dimorient , "z" ))
1018 { dim_entry->coord_axis = COORD_Z ; }
1019 else
1020 { dim_entry->coord_axis = COORD_C ; }
1021 return(0) ;
1022 }
1023
1024 /* integrity checking of dimension list; make sure that
1025 namelist specified dimensions have an associated namelist variable */
1026 int
1027 check_dimspecs()
1028 {
1029 node_t * p, *q ;
1030 int ord ;
1031
1032 for ( p = Dim ; p != NULL ; p = p->next )
1033 {
1034 if ( p->len_defined_how == DOMAIN_STANDARD )
1035 {
1036 if ( p->dim_order < 1 || p->dim_order > 3 )
1037 {
1038 fprintf(stderr,"WARNING: illegal dim order %d for dimspec %s\n",p->dim_order,p->name) ;
1039 }
1040 ord = p->dim_order-1 ;
1041 if ( model_order[ord] != p->coord_axis )
1042 {
1043 if ( model_order[ord] == -1 ) model_order[ord] = p->coord_axis ;
1044 else
1045 {
1046 fprintf(stderr,"WARNING: coord-axis/dim-order for dimspec %s is inconsistent with previous dimspec.\n",p->name) ;
1047 }
1048 }
1049 }
1050 else if ( p->len_defined_how == NAMELIST )
1051 {
1052 if ( strcmp( p->assoc_nl_var_s, "1" ) ) /* if not equal to "1" */
1053 {
1054 if (( q = get_entry(p->assoc_nl_var_s,Domain.fields)) == NULL )
1055 {
1056 fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n",
1057 p->assoc_nl_var_s,p->name ) ;
1058 return(1) ;
1059 }
1060 if ( ! q->node_kind & RCONFIG )
1061 {
1062 fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n",
1063 p->assoc_nl_var_s,p->name ) ;
1064 return(1) ;
1065 }
1066 if ( strcmp( q->type->name , "integer" ) ) /* if not integer */
1067 {
1068 fprintf(stderr,"WARNING: namelist variable %s must be an integer if used to define dimension %s\n",
1069 p->assoc_nl_var_s,p->name ) ;
1070 return(1) ;
1071 }
1072 if ( strcmp( q->nentries , "1" ) ) /* if not 1 entry */
1073 {
1074 fprintf(stderr,"WARNING: namelist variable %s must have only one entry if used to define dimension %s\n",
1075 p->assoc_nl_var_s,p->name ) ;
1076 return(1) ;
1077 }
1078 }
1079 if (( q = get_entry(p->assoc_nl_var_e,Domain.fields)) == NULL )
1080 {
1081 fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n",
1082 p->assoc_nl_var_e,p->name ) ;
1083 return(1) ;
1084 }
1085 if ( ! q->node_kind & RCONFIG )
1086 {
1087 fprintf(stderr,"WARNING: no namelist variable %s defined for dimension %s\n",
1088 p->assoc_nl_var_e,p->name ) ;
1089 return(1) ;
1090 }
1091 if ( strcmp( q->type->name , "integer" ) ) /* if not integer */
1092 {
1093 fprintf(stderr,"WARNING: namelist variable %s must be an integer if used to define dimension %s\n",
1094 p->assoc_nl_var_e,p->name ) ;
1095 return(1) ;
1096 }
1097 if ( strcmp( q->nentries , "1" ) ) /* if not 1 entry */
1098 {
1099 fprintf(stderr,"WARNING: namelist variable %s must have only one entry if used to define dimension %s\n",
1100 p->assoc_nl_var_e,p->name ) ;
1101 return(1) ;
1102 }
1103 }
1104 }
1105 return(0) ;
1106 }
1107
1108 int
1109 set_dim_order ( char * dimorder , node_t * dim_entry )
1110 {
1111 dim_entry->dim_order = atoi(dimorder) ;
1112 return(0) ;
1113 }
1114
1115 int
1116 init_parser()
1117 {
1118 model_order[0] = -1 ;
1119 model_order[1] = -1 ;
1120 model_order[2] = -1 ;
1121 return(0) ;
1122 }
Mirror of the official repository at https://github.com/wrf-model/WRF