gen_config.c
References to this file elsewhere.
1 #include <stdio.h>
2 #include <stdlib.h>
3
4 #include "protos.h"
5 #include "registry.h"
6 #include "data.h"
7 #include <string.h>
8 #include <strings.h>
9 #include "sym.h"
10
11 int
12 gen_namelist_defines ( char * dirname , int sw_dimension )
13 {
14 FILE * fp ;
15 char fname[NAMELEN] ;
16 char fn[NAMELEN] ;
17 node_t *p ;
18
19 sprintf( fn, "namelist_defines%s.inc", sw_dimension?"":"2" ) ;
20 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
21 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
22 print_warning(fp,fname) ;
23
24 fprintf(fp,"integer :: first_item_in_struct\n") ;
25 for ( p = Domain.fields ; p != NULL ; p = p-> next )
26 {
27 if ( p->node_kind & RCONFIG )
28 {
29 if ( sw_dimension )
30 {
31 if ( !strcmp( p->nentries, "1" ) )
32 fprintf(fp,"%s :: %s\n",p->type->name ,p->name) ;
33 else if ( strcmp( p->nentries, "-" ) ) /* if not equal to "-" */
34 fprintf(fp,"%s , DIMENSION(%s) :: %s\n",p->type->name ,p->nentries,p->name) ;
35 }
36 else
37 {
38 fprintf(fp,"%s :: %s\n",p->type->name ,p->name) ;
39 }
40 }
41 }
42 fprintf(fp,"integer :: last_item_in_struct\n") ;
43
44 close_the_file( fp ) ;
45 return(0) ;
46 }
47
48 int
49 gen_namelist_defaults ( char * dirname )
50 {
51 FILE * fp ;
52 char fname[NAMELEN] ;
53 char *fn = "namelist_defaults.inc" ;
54 node_t *p ;
55
56 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
57 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
58 print_warning(fp,fname) ;
59
60 for ( p = Domain.fields ; p != NULL ; p = p-> next )
61 {
62 if ( p->node_kind & RCONFIG && strcmp(p->dflt,"-") && strcmp(p->dflt,""))
63 {
64 if ( !strncmp ( p->type->name , "character", 9 ) ) {
65 fprintf(fp,"%s = \"%s\"\n",p->name ,p->dflt) ;
66 } else {
67 fprintf(fp,"%s = %s\n",p->name ,p->dflt) ;
68 }
69 }
70 }
71
72 close_the_file( fp ) ;
73 return(0) ;
74 }
75
76
77 int
78 gen_namelist_statements ( char * dirname )
79 {
80 FILE * fp ;
81 char fname[NAMELEN] ;
82 char * fn = "namelist_statements.inc" ;
83 char howset[NAMELEN] ;
84 char *p1, *p2 ;
85 node_t *p ;
86
87 strcpy( fname, fn ) ;
88 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
89 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
90 print_warning(fp,fname) ;
91
92 for ( p = Domain.fields ; p != NULL ; p = p-> next )
93 {
94 if ( p->node_kind & RCONFIG )
95 {
96 strcpy(howset,p->howset) ;
97 if (( p1 = strtok(howset,",")) != NULL )
98 {
99 p2 = strtok(NULL,",") ;
100 if ( !strcmp(p1,"namelist") )
101 {
102 if ( p2 == NULL )
103 {
104 fprintf(stderr,
105 "Warning: no namelist section specified for nl %s\n",p->name) ;
106 continue ;
107 }
108 fprintf(fp,"NAMELIST /%s/ %s\n",p2,p->name) ;
109 }
110 }
111 }
112 }
113
114 close_the_file( fp ) ;
115 return(0) ;
116 }
117
118 int
119 gen_namelist_script ( char * dirname )
120 {
121 FILE * fp ;
122 char fname[NAMELEN] ;
123 char *fn = "namelist_script.inc" ;
124 node_t *p,*q ;
125 char *p1, *p2, *p3, *p4 ;
126 char *i;
127 char howset1[NAMELEN] ;
128 char howset2[NAMELEN] ;
129
130 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
131 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
132
133 sym_forget() ;
134
135 fprintf(fp,"# Machine generated, do not edit\n\n") ;
136 fprintf(fp,"FILE=${1:-namelist.input}\n\n");
137
138 for ( p = Domain.fields ; p != NULL ; p = p-> next )
139 {
140 if ( p->node_kind & RCONFIG )
141 {
142 strcpy(howset1,p->howset) ;
143 p1 = strtok(howset1,",") ;
144 p2 = strtok(NULL,",") ;
145 if ( !strcmp(p1,"namelist") ) {
146 if ( p2 == NULL ) {
147 fprintf(stderr,
148 "Warning: no namelist section specified for nl %s\n",p->name) ;
149 continue ;
150 }
151 if (sym_get( p2 ) == NULL) { /* not in table yet */
152 fprintf(fp,"echo \\&%s >> $FILE\n",p2) ;
153 for ( q = Domain.fields ; q != NULL ; q = q-> next ) {
154 if ( q->node_kind & RCONFIG) {
155 strcpy(howset2,q->howset) ;
156 p3 = strtok(howset2,",") ;
157 p4 = strtok(NULL,",") ;
158 if ( p4 == NULL ) {
159 continue ;
160 }
161
162 if ( !strcmp(p2,p4)) {
163 fprintf(fp,"if test ! -z \"$NL_") ;
164 for (i=q->name; *i!='\0'; i++) {
165 fputc(toupper(*i),fp);
166 }
167 if ( !strncmp(q->type->name,"character",9)) {
168 fprintf(fp,"\"; then echo \"%s=\\\"${NL_",q->name) ;
169 for (i=q->name; *i!='\0'; i++) {
170 fputc(toupper(*i),fp);
171 }
172 fprintf(fp,"}\\\",\"") ;
173 } else {
174 fprintf(fp,"\"; then echo \"%s=${NL_",q->name) ;
175 for (i=q->name; *i!='\0'; i++) {
176 fputc(toupper(*i),fp);
177 }
178 fprintf(fp,"},\"") ;
179 }
180
181 fprintf(fp," >> $FILE;fi\n") ;
182 }
183
184 }
185 }
186 fprintf(fp,"echo / >> $FILE\n") ;
187 sym_add(p2) ;
188 }
189 }
190 }
191 }
192
193 fprintf(fp,"echo \\&namelist_quilt >> $FILE\n");
194 fprintf(fp,"if test ! -z \"$NL_NIO_TASKS_PER_GROUP\"; then echo \"nio_tasks_per_group=${NL_NIO_TASKS_PER_GROUP},\" >> $FILE;fi\n");
195 fprintf(fp,"if test ! -z \"$NL_NIO_GROUPS\"; then echo \"nio_groups=${NL_NIO_GROUPS},\" >> $FILE;fi\n");
196 fprintf(fp,"echo / >> $FILE\n");
197
198 fclose( fp ) ;
199 return(0) ;
200 }
201
202
203 int
204 gen_get_nl_config ( char * dirname )
205 {
206 FILE * fp ;
207 char fname[NAMELEN] ;
208 char * fn = "get_nl_config.inc" ;
209 char * gs, * intnt ;
210 char howset[NAMELEN] ;
211 node_t *p ;
212 int sw ;
213
214
215 strcpy( fname, fn ) ;
216 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
217 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
218 print_warning(fp,fname) ;
219
220 for ( sw = 0 ; sw < 2 ; sw++ )
221 {
222 if ( sw == 0 ) { gs = "get" ; intnt = "OUT" ; } else { gs = "set" ; intnt = "IN" ; }
223 for ( p = Domain.fields ; p != NULL ; p = p-> next )
224 {
225 if ( p->node_kind & RCONFIG )
226 {
227 strcpy(howset,p->howset) ;
228 fprintf(fp,"SUBROUTINE nl_%s_%s ( id_id , %s )\n",gs,p->name, p->name) ;
229 if ( sw_ifort_kludge ) {
230 fprintf(fp," USE module_configure\n") ;
231 }
232 fprintf(fp," %s , INTENT(%s) :: %s\n",p->type->name,intnt,p->name) ;
233 fprintf(fp," INTEGER id_id\n") ;
234 fprintf(fp," CHARACTER*80 emess\n") ;
235 if ( sw == 0 ) /* get */
236 {
237 if ( !strcmp( p->nentries, "1" )) {
238 if ( ! sw_ifort_kludge ) {
239 fprintf(fp," IF ( id_id .NE. 1 ) THEN\n") ;
240 fprintf(fp," call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n",
241 gs,p->name, p->name ) ;
242 fprintf(fp," ENDIF\n" ) ;
243 }
244 if ( !strncmp(p->type->name,"character",9)) {
245 fprintf(fp," %s = trim(model_config_rec%%%s)\n",p->name,p->name) ;
246 }else{
247 fprintf(fp," %s = model_config_rec%%%s\n",p->name,p->name) ;
248 }
249 } else {
250 if ( ! sw_ifort_kludge ) {
251 if ( !strcmp( p->nentries, "max_domains" )) {
252 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ;
253 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ;
254 } else if ( !strcmp( p->nentries, "max_moves" )) {
255 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ;
256 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ;
257 } else if ( !strcmp( p->nentries, "max_eta" )) {
258 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ;
259 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ;
260 } else if ( !strcmp( p->nentries, "max_outer_iterations" )) {
261 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. max_outer_iterations ) THEN\n") ;
262 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range eps number: ',id_id\n",gs,p->name) ;
263 } else if ( !strcmp( p->nentries, "max_instruments" )) {
264 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. max_instruments ) THEN\n") ;
265 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range instruments number: ',id_id\n",gs,p->name) ;
266 } else {
267 fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, max_eta, max_outer_iterations, or max_instruments \n") ;
268 }
269 fprintf(fp," CALL wrf_error_fatal(emess)\n") ;
270 fprintf(fp," ENDIF\n" ) ;
271 }
272 fprintf(fp," %s = model_config_rec%%%s(id_id)\n",p->name,p->name) ;
273 }
274 }
275 else /* set */
276 {
277 if ( !strcmp( p->nentries, "1" )) {
278 if ( ! sw_ifort_kludge ) {
279 fprintf(fp," IF ( id_id .NE. 1 ) THEN\n") ;
280 fprintf(fp," call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n",
281 gs,p->name, p->name ) ;
282 fprintf(fp," ENDIF\n" ) ;
283 }
284 if ( !strncmp(p->type->name,"character",9)) {
285 fprintf(fp," model_config_rec%%%s = trim(%s) \n",p->name,p->name) ;
286 }else{
287 fprintf(fp," model_config_rec%%%s = %s \n",p->name,p->name) ;
288 }
289 } else {
290 if ( ! sw_ifort_kludge ) {
291 if ( !strcmp( p->nentries, "max_domains" )) {
292 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ;
293 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ;
294 } else if ( !strcmp( p->nentries, "max_moves" )) {
295 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ;
296 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ;
297 } else if ( !strcmp( p->nentries, "max_eta" )) {
298 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ;
299 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ;
300 } else if ( !strcmp( p->nentries, "max_outer_iterations" )) {
301 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. max_outer_iterations ) THEN\n") ;
302 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range eps number: ',id_id\n",gs,p->name) ;
303 } else if ( !strcmp( p->nentries, "max_instruments" )) {
304 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. max_instruments ) THEN\n") ;
305 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range instruments number: ',id_id\n",gs,p->name) ;
306 } else {
307 fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, max_eta, max_outer_iterations, or max_instruments \n") ;
308 }
309 fprintf(fp," CALL wrf_error_fatal(emess)\n") ;
310 fprintf(fp," ENDIF\n" ) ;
311 }
312 fprintf(fp," model_config_rec%%%s(id_id) = %s\n",p->name,p->name) ;
313 }
314 }
315 fprintf(fp," RETURN\n") ;
316 fprintf(fp,"END SUBROUTINE nl_%s_%s\n",gs,p->name ) ;
317 }
318 }
319 }
320 close_the_file( fp ) ;
321 return(0) ;
322 }
323
324 int
325 gen_config_assigns ( char * dirname )
326 {
327 FILE * fp ;
328 char fname[NAMELEN] ;
329 char * fn = "config_assigns.inc" ;
330 char tmp[NAMELEN] ;
331 node_t *p ;
332
333 strcpy( fname, fn ) ;
334 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
335 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
336 print_warning(fp,fname) ;
337
338 fprintf(fp,"! Contains config assign statements for module_domain.F.\n") ;
339 fprintf(fp,"#ifndef SOURCE_RECORD\n") ;
340 fprintf(fp,"# define SOURCE_RECORD cfg%%\n") ;
341 fprintf(fp,"#endif\n") ;
342 fprintf(fp,"#ifndef SOURCE_REC_DEX\n") ;
343 fprintf(fp,"# define SOURCE_REC_DEX\n") ;
344 fprintf(fp,"#endif\n") ;
345 fprintf(fp,"#ifndef DEST_RECORD\n") ;
346 fprintf(fp,"# define DEST_RECORD new_grid%%\n") ;
347 fprintf(fp,"#endif\n") ;
348
349 for ( p = Domain.fields ; p != NULL ; p = p-> next )
350 {
351 if ( p->node_kind & RCONFIG )
352 {
353 if ( !strcmp( p->nentries, "1" ))
354 strcpy( tmp, "" ) ;
355 else
356 strcpy( tmp, "SOURCE_REC_DEX" ) ;
357 fprintf(fp," DEST_RECORD %-26s = SOURCE_RECORD %s %s\n",p->name,p->name,tmp) ;
358 }
359 }
360 close_the_file( fp ) ;
361 return(0) ;
362 }
363
364 int
365 gen_config_reads ( char * dirname )
366 {
367 FILE * fp ;
368 int i, n_nml ;
369 char fname[NAMELEN] ;
370 char * fn = "config_reads.inc" ;
371 char howset[NAMELEN] ;
372 char *p1, *p2 ;
373 node_t *p ;
374
375 strcpy( fname, fn ) ;
376 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
377 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
378 print_warning(fp,fname) ;
379
380 fprintf(fp,"! Contains namelist statements for module_config.F.\n") ;
381 fprintf(fp,"#ifndef NAMELIST_READ_UNIT\n") ;
382 fprintf(fp,"# define NAMELIST_READ_UNIT nml_read_unit\n") ;
383 fprintf(fp,"#endif\n") ;
384 fprintf(fp,"#ifndef NAMELIST_WRITE_UNIT\n") ;
385 fprintf(fp,"# define NAMELIST_WRITE_UNIT nml_write_unit\n") ;
386 fprintf(fp,"#endif\n") ;
387 fprintf(fp,"!\n") ;
388
389 sym_forget() ;
390
391 /*
392 Count how many namelists are defined in the registry
393 */
394 n_nml = 0 ;
395 for ( p = Domain.fields ; p != NULL ; p = p-> next )
396 {
397 if ( p->node_kind & RCONFIG )
398 {
399 strcpy(howset,p->howset) ;
400 p1 = strtok(howset,",") ;
401 p2 = strtok(NULL,",") ;
402 if ( !strcmp(p1,"namelist") )
403 {
404 if (sym_get( p2 ) == NULL) /* not in table yet */
405 {
406 n_nml ++ ;
407 sym_add(p2) ;
408 }
409 }
410 }
411 }
412
413 sym_forget() ;
414
415 fprintf(fp," nml_read_error = .FALSE.\n") ;
416 fprintf(fp," NML_LOOP : DO i=1,%i\n", n_nml) ;
417 fprintf(fp," REWIND ( UNIT = NAMELIST_READ_UNIT )\n") ;
418 fprintf(fp," SELECT CASE ( i )\n") ;
419 i = 1;
420 for ( p = Domain.fields ; p != NULL ; p = p-> next )
421 {
422 if ( p->node_kind & RCONFIG )
423 {
424 strcpy(howset,p->howset) ;
425 p1 = strtok(howset,",") ;
426 p2 = strtok(NULL,",") ;
427 if ( !strcmp(p1,"namelist") )
428 {
429 if ( p2 == NULL )
430 {
431 fprintf(stderr,
432 "Warning: no namelist section specified for nl %s\n",p->name) ;
433 continue ;
434 }
435 if (sym_get( p2 ) == NULL) /* not in table yet */
436 {
437 fprintf(fp," CASE ( %i ) \n",i) ;
438 fprintf(fp," nml_name = \"%s\"\n",p2) ;
439 fprintf(fp," READ ( UNIT = NAMELIST_READ_UNIT , NML = %s , ERR=9201, END=9202 )\n",p2) ;
440 fprintf(fp,"#ifndef NO_NAMELIST_PRINT\n") ;
441 fprintf(fp," WRITE ( UNIT = NAMELIST_WRITE_UNIT, NML = %s )\n",p2) ;
442 fprintf(fp,"#endif\n") ;
443 fprintf(fp," CYCLE NML_LOOP\n") ;
444 i ++ ;
445 sym_add(p2) ;
446 }
447 }
448 }
449 }
450 fprintf(fp," END SELECT\n") ;
451 fprintf(fp,"9201 CALL wrf_message(\"Error while reading namelist \"//TRIM(nml_name))\n") ;
452 fprintf(fp," nml_read_error = .TRUE.\n") ;
453 fprintf(fp," CYCLE NML_LOOP\n") ;
454 fprintf(fp,"9202 CALL wrf_message(\"Namelist \"//TRIM(nml_name)//\" not found in namelist.input.\"// & \n") ;
455 fprintf(fp," \" Using registry defaults for variables in \"//TRIM(nml_name))\n") ;
456 fprintf(fp," END DO NML_LOOP\n") ;
457 fprintf(fp," \n") ;
458 fprintf(fp," IF ( nml_read_error ) CALL wrf_error_fatal(\"Errors while reading one or more namelists from namelist.input.\")\n") ;
459
460 close_the_file( fp ) ;
461 return(0) ;
462 }
463