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
137 for ( p = Domain.fields ; p != NULL ; p = p-> next )
138 {
139 if ( p->node_kind & RCONFIG )
140 {
141 strcpy(howset1,p->howset) ;
142 p1 = strtok(howset1,",") ;
143 p2 = strtok(NULL,",") ;
144 if ( !strcmp(p1,"namelist") ) {
145 if ( p2 == NULL ) {
146 fprintf(stderr,
147 "Warning: no namelist section specified for nl %s\n",p->name) ;
148 continue ;
149 }
150 if (sym_get( p2 ) == NULL) { /* not in table yet */
151 fprintf(fp,"echo \\&%s >> namelist.input\n",p2) ;
152 for ( q = Domain.fields ; q != NULL ; q = q-> next ) {
153 if ( q->node_kind & RCONFIG) {
154 strcpy(howset2,q->howset) ;
155 p3 = strtok(howset2,",") ;
156 p4 = strtok(NULL,",") ;
157 if ( p4 == NULL ) {
158 continue ;
159 }
160
161 if ( !strcmp(p2,p4)) {
162 fprintf(fp,"if test ! -z \"$NL_") ;
163 for (i=q->name; *i!='\0'; i++) {
164 fputc(toupper(*i),fp);
165 }
166 if ( !strncmp(q->type->name,"character",9)) {
167 fprintf(fp,"\"; then echo \"%s=\\\"${NL_",q->name) ;
168 for (i=q->name; *i!='\0'; i++) {
169 fputc(toupper(*i),fp);
170 }
171 fprintf(fp,"}\\\",\"") ;
172 } else {
173 fprintf(fp,"\"; then echo \"%s=${NL_",q->name) ;
174 for (i=q->name; *i!='\0'; i++) {
175 fputc(toupper(*i),fp);
176 }
177 fprintf(fp,"},\"") ;
178 }
179
180 fprintf(fp," >> namelist.input;fi\n") ;
181 }
182
183 }
184 }
185 fprintf(fp,"echo / >> namelist.input\n") ;
186 sym_add(p2) ;
187 }
188 }
189 }
190 }
191
192 fclose( fp ) ;
193 return(0) ;
194 }
195
196
197 int
198 gen_get_nl_config ( char * dirname )
199 {
200 FILE * fp ;
201 char fname[NAMELEN] ;
202 char * fn = "get_nl_config.inc" ;
203 char * gs, * intnt ;
204 char howset[NAMELEN] ;
205 node_t *p ;
206 int sw ;
207
208
209 strcpy( fname, fn ) ;
210 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
211 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
212 print_warning(fp,fname) ;
213
214 for ( sw = 0 ; sw < 2 ; sw++ )
215 {
216 if ( sw == 0 ) { gs = "get" ; intnt = "OUT" ; } else { gs = "set" ; intnt = "IN" ; }
217 for ( p = Domain.fields ; p != NULL ; p = p-> next )
218 {
219 if ( p->node_kind & RCONFIG )
220 {
221 strcpy(howset,p->howset) ;
222 fprintf(fp,"SUBROUTINE nl_%s_%s ( id_id , %s )\n",gs,p->name, p->name) ;
223 if ( sw_ifort_kludge ) {
224 fprintf(fp," USE module_configure\n") ;
225 }
226 fprintf(fp," %s , INTENT(%s) :: %s\n",p->type->name,intnt,p->name) ;
227 fprintf(fp," INTEGER id_id\n") ;
228 fprintf(fp," CHARACTER*80 emess\n") ;
229 if ( sw == 0 ) /* get */
230 {
231 if ( !strcmp( p->nentries, "1" )) {
232 if ( ! sw_ifort_kludge ) {
233 fprintf(fp," IF ( id_id .NE. 1 ) THEN\n") ;
234 fprintf(fp," call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n",
235 gs,p->name, p->name ) ;
236 fprintf(fp," ENDIF\n" ) ;
237 }
238 if ( !strncmp(p->type->name,"character",9)) {
239 fprintf(fp," %s = trim(model_config_rec%%%s)\n",p->name,p->name) ;
240 }else{
241 fprintf(fp," %s = model_config_rec%%%s\n",p->name,p->name) ;
242 }
243 } else {
244 if ( ! sw_ifort_kludge ) {
245 if ( !strcmp( p->nentries, "max_domains" )) {
246 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ;
247 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ;
248 fprintf(fp," CALL wrf_error_fatal(emess)\n") ;
249 fprintf(fp," ENDIF\n" ) ;
250 } else if ( !strcmp( p->nentries, "max_moves" )) {
251 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ;
252 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ;
253 fprintf(fp," CALL wrf_error_fatal(emess)\n") ;
254 fprintf(fp," ENDIF\n" ) ;
255 } else if ( !strcmp( p->nentries, "max_eta" )) {
256 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ;
257 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ;
258 fprintf(fp," CALL wrf_error_fatal(emess)\n") ;
259 fprintf(fp," ENDIF\n" ) ;
260 } else {
261 /* JRB I can't see we can't have generic multi-elements
262 fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains or max_moves\n") ;
263 */
264 }
265 }
266 fprintf(fp," %s = model_config_rec%%%s(id_id)\n",p->name,p->name) ;
267 }
268 }
269 else /* set */
270 {
271 if ( !strcmp( p->nentries, "1" )) {
272 if ( ! sw_ifort_kludge ) {
273 fprintf(fp," IF ( id_id .NE. 1 ) THEN\n") ;
274 fprintf(fp," call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n",
275 gs,p->name, p->name ) ;
276 fprintf(fp," ENDIF\n" ) ;
277 }
278 if ( !strncmp(p->type->name,"character",9)) {
279 fprintf(fp," model_config_rec%%%s = trim(%s) \n",p->name,p->name) ;
280 }else{
281 fprintf(fp," model_config_rec%%%s = %s \n",p->name,p->name) ;
282 }
283 } else {
284 if ( ! sw_ifort_kludge ) {
285 if ( !strcmp( p->nentries, "max_domains" )) {
286 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ;
287 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ;
288 fprintf(fp," CALL wrf_error_fatal(emess)\n") ;
289 fprintf(fp," ENDIF\n" ) ;
290 } else if ( !strcmp( p->nentries, "max_moves" )) {
291 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ;
292 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ;
293 fprintf(fp," CALL wrf_error_fatal(emess)\n") ;
294 fprintf(fp," ENDIF\n" ) ;
295 } else if ( !strcmp( p->nentries, "max_eta" )) {
296 fprintf(fp," IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ;
297 fprintf(fp," WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ;
298 fprintf(fp," CALL wrf_error_fatal(emess)\n") ;
299 fprintf(fp," ENDIF\n" ) ;
300 } else {
301 /* JRB I cannot see why we cannot have multi-element ones
302
303 fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, or max_eta \n") ;
304 */ }
305 }
306 fprintf(fp," model_config_rec%%%s(id_id) = %s\n",p->name,p->name) ;
307 }
308 }
309 fprintf(fp," RETURN\n") ;
310 fprintf(fp,"END SUBROUTINE nl_%s_%s\n",gs,p->name ) ;
311 }
312 }
313 }
314 close_the_file( fp ) ;
315 return(0) ;
316 }
317
318 int
319 gen_config_assigns ( char * dirname )
320 {
321 FILE * fp ;
322 char fname[NAMELEN] ;
323 char * fn = "config_assigns.inc" ;
324 char tmp[NAMELEN] ;
325 node_t *p ;
326
327 strcpy( fname, fn ) ;
328 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
329 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
330 print_warning(fp,fname) ;
331
332 fprintf(fp,"! Contains config assign statements for module_domain.F.\n") ;
333 fprintf(fp,"#ifndef SOURCE_RECORD\n") ;
334 fprintf(fp,"# define SOURCE_RECORD cfg%%\n") ;
335 fprintf(fp,"#endif\n") ;
336 fprintf(fp,"#ifndef SOURCE_REC_DEX\n") ;
337 fprintf(fp,"# define SOURCE_REC_DEX\n") ;
338 fprintf(fp,"#endif\n") ;
339 fprintf(fp,"#ifndef DEST_RECORD\n") ;
340 fprintf(fp,"# define DEST_RECORD new_grid%%\n") ;
341 fprintf(fp,"#endif\n") ;
342
343 for ( p = Domain.fields ; p != NULL ; p = p-> next )
344 {
345 if ( p->node_kind & RCONFIG )
346 {
347 if ( !strcmp( p->nentries, "1" ))
348 strcpy( tmp, "" ) ;
349 else
350 strcpy( tmp, "SOURCE_REC_DEX" ) ;
351 fprintf(fp," DEST_RECORD %-26s = SOURCE_RECORD %s %s\n",p->name,p->name,tmp) ;
352 }
353 }
354 close_the_file( fp ) ;
355 return(0) ;
356 }
357
358 int
359 gen_config_reads ( char * dirname )
360 {
361 FILE * fp ;
362 char fname[NAMELEN] ;
363 char * fn = "config_reads.inc" ;
364 char howset[NAMELEN] ;
365 char *p1, *p2 ;
366 node_t *p ;
367
368 strcpy( fname, fn ) ;
369 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
370 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
371 print_warning(fp,fname) ;
372
373 fprintf(fp,"! Contains namelist statements for module_config.F.\n") ;
374 fprintf(fp,"#ifndef NAMELIST_READ_UNIT\n") ;
375 fprintf(fp,"# define NAMELIST_READ_UNIT nml_read_unit\n") ;
376 fprintf(fp,"#endif\n") ;
377 fprintf(fp,"#ifndef NAMELIST_WRITE_UNIT\n") ;
378 fprintf(fp,"# define NAMELIST_WRITE_UNIT nml_write_unit\n") ;
379 fprintf(fp,"#endif\n") ;
380 fprintf(fp,"!\n") ;
381
382 sym_forget() ;
383
384 for ( p = Domain.fields ; p != NULL ; p = p-> next )
385 {
386 if ( p->node_kind & RCONFIG )
387 {
388 strcpy(howset,p->howset) ;
389 p1 = strtok(howset,",") ;
390 p2 = strtok(NULL,",") ;
391 if ( !strcmp(p1,"namelist") )
392 {
393 if ( p2 == NULL )
394 {
395 fprintf(stderr,
396 "Warning: no namelist section specified for nl %s\n",p->name) ;
397 continue ;
398 }
399 if (sym_get( p2 ) == NULL) /* not in table yet */
400 {
401 fprintf(fp," READ ( UNIT = NAMELIST_READ_UNIT , NML = %s , IOSTAT=io_status )\n",p2) ;
402 fprintf(fp," IF (io_status /= 0) THEN\n") ;
403 fprintf(fp," CALL wrf_error_fatal(\"Cannot read namelist %s\")\n",p2) ;
404 fprintf(fp," END IF\n") ;
405 fprintf(fp,"#ifndef NO_NAMELIST_PRINT\n") ;
406 fprintf(fp," WRITE ( UNIT = NAMELIST_WRITE_UNIT, NML = %s )\n",p2) ;
407 fprintf(fp,"#endif\n") ;
408 sym_add(p2) ;
409 }
410
411 }
412 }
413 }
414 close_the_file( fp ) ;
415 return(0) ;
416 }
417