source: trunk/WRF.COMMON/WRFV3/tools/gen_config.c @ 3431

Last change on this file since 3431 was 2759, checked in by aslmd, 2 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 15.6 KB
Line 
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
11int
12gen_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
48int
49gen_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
77int
78gen_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
118int
119gen_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
203int
204gen_get_nl_config ( char * dirname )
205{
206  FILE * fp ;
207  char  fname[NAMELEN] ;
208  char * fn = "_nl_config.inc" ;
209  char * gs, * intnt ;
210  char  howset[NAMELEN] ;
211  node_t *p ;
212  int sw ;
213  int num_rconfigs = 0 ;
214  int i, half, j ;
215
216  for ( p = Domain.fields ; p != NULL ; p = p-> next ) { if ( p->node_kind & RCONFIG ) { num_rconfigs++ ; } }  /* howmany deez guys? */
217
218  for ( half = 0, j=0 ; half < num_rconfigs ; half += (num_rconfigs+1)/2, j++ ) {    /* break the files in half so we don't kill the compilers as much */
219  for ( sw = 0 ; sw < 2 ; sw++ ) {
220
221  if ( sw == 0 ) { gs = "get" ; intnt = "OUT" ; } else { gs = "set" ; intnt = "IN" ; }
222
223  strcpy( fname, fn ) ;
224  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%d%s",dirname,gs,j,fn) ; }
225  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
226  print_warning(fp,fname) ;
227
228  for ( p = Domain.fields, i = -1 ; p != NULL ; p = p-> next )
229  {
230    if ( p->node_kind & RCONFIG ) {
231       i++ ;
232    if ( (i >= half) && (i < half + (num_rconfigs+1)/2) )
233    {
234      strcpy(howset,p->howset) ;
235      fprintf(fp,"SUBROUTINE nl_%s_%s ( id_id , %s )\n",gs,p->name, p->name) ;
236      if ( sw_fort_kludge ) {
237        fprintf(fp,"  USE module_configure, ONLY : model_config_rec \n") ;
238      }
239      fprintf(fp,"  %s , INTENT(%s) :: %s\n",p->type->name,intnt,p->name) ;
240      fprintf(fp,"  INTEGER id_id\n") ;
241      fprintf(fp,"  CHARACTER*80 emess\n") ;
242      if ( sw == 0 ) /* get */
243      {
244        if ( !strcmp( p->nentries, "1" )) {
245          if ( ! sw_fort_kludge ) {
246            fprintf(fp,"  IF ( id_id .NE. 1 ) THEN\n") ;
247            fprintf(fp,"    call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n",
248                            gs,p->name, p->name ) ;
249            fprintf(fp,"  ENDIF\n" ) ;
250          }
251          if ( !strncmp(p->type->name,"character",9)) {
252            fprintf(fp,"  %s = trim(model_config_rec%%%s)\n",p->name,p->name) ;
253          }else{
254            fprintf(fp,"  %s = model_config_rec%%%s\n",p->name,p->name) ;
255          }
256        } else {
257          if ( ! sw_fort_kludge ) {
258            if        ( !strcmp( p->nentries, "max_domains" )) {
259              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ;
260              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ;
261            } else if ( !strcmp( p->nentries, "max_moves" )) {
262              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ;
263              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ;
264            } else if ( !strcmp( p->nentries, "max_eta" )) {
265              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ;
266              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ;
267            } else if ( !strcmp( p->nentries, "max_outer_iterations" )) {
268              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. max_outer_iterations ) THEN\n") ;
269              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range eps number: ',id_id\n",gs,p->name) ;
270            } else if ( !strcmp( p->nentries, "max_instruments" )) {
271              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. max_instruments ) THEN\n") ;
272              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range instruments number: ',id_id\n",gs,p->name) ;
273            } else {
274              fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, max_eta, max_outer_iterations, or max_instruments \n") ;
275            }
276            fprintf(fp,"    CALL wrf_error_fatal(emess)\n") ;
277            fprintf(fp,"  ENDIF\n" ) ;
278          }
279          fprintf(fp,"  %s = model_config_rec%%%s(id_id)\n",p->name,p->name) ;
280        }
281      }
282      else   /* set */
283      {
284        if ( !strcmp( p->nentries, "1" )) {
285          if ( ! sw_fort_kludge ) {
286            fprintf(fp,"  IF ( id_id .NE. 1 ) THEN\n") ;
287            fprintf(fp,"    call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n",
288                            gs,p->name, p->name ) ;
289            fprintf(fp,"  ENDIF\n" ) ;
290          }
291          if ( !strncmp(p->type->name,"character",9)) {
292            fprintf(fp,"  model_config_rec%%%s = trim(%s) \n",p->name,p->name) ;
293          }else{
294            fprintf(fp,"  model_config_rec%%%s = %s \n",p->name,p->name) ;
295          }
296        } else {
297          if ( ! sw_fort_kludge ) {
298            if        ( !strcmp( p->nentries, "max_domains" )) {
299              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ;
300              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ;
301            } else if ( !strcmp( p->nentries, "max_moves" )) {
302              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ;
303              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ;
304            } else if ( !strcmp( p->nentries, "max_eta" )) {
305              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ;
306              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ;
307            } else if ( !strcmp( p->nentries, "max_outer_iterations" )) {
308              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. max_outer_iterations ) THEN\n") ;
309              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range eps number: ',id_id\n",gs,p->name) ;
310            } else if ( !strcmp( p->nentries, "max_instruments" )) {
311              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. max_instruments ) THEN\n") ;
312              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range instruments number: ',id_id\n",gs,p->name) ;
313            } else {
314              fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, max_eta, max_outer_iterations, or max_instruments \n") ;
315            }
316            fprintf(fp,"    CALL wrf_error_fatal(emess)\n") ;
317            fprintf(fp,"  ENDIF\n" ) ;
318          }
319          fprintf(fp,"  model_config_rec%%%s(id_id) = %s\n",p->name,p->name) ;
320        }
321      }
322      fprintf(fp,"  RETURN\n") ;
323      fprintf(fp,"END SUBROUTINE nl_%s_%s\n",gs,p->name ) ;
324    }
325    }
326  }
327  close_the_file( fp ) ;
328  }
329  } /* halfs */
330  return(0) ;
331}
332
333int
334gen_config_assigns ( char * dirname )
335{
336  FILE * fp ;
337  char  fname[NAMELEN] ;
338  char * fn = "config_assigns.inc" ;
339  char  tmp[NAMELEN] ;
340  node_t *p ;
341
342  strcpy( fname, fn ) ;
343  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
344  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
345  print_warning(fp,fname) ;
346
347  fprintf(fp,"! Contains config assign statements for module_domain.F.\n") ;
348  fprintf(fp,"#ifndef SOURCE_RECORD\n") ;
349  fprintf(fp,"#  define SOURCE_RECORD cfg%%\n") ;
350  fprintf(fp,"#endif\n") ;
351  fprintf(fp,"#ifndef SOURCE_REC_DEX\n") ;
352  fprintf(fp,"#  define SOURCE_REC_DEX\n") ;
353  fprintf(fp,"#endif\n") ;
354  fprintf(fp,"#ifndef DEST_RECORD\n") ;
355  fprintf(fp,"#  define DEST_RECORD new_grid%%\n") ;
356  fprintf(fp,"#endif\n") ;
357
358  for ( p = Domain.fields ; p != NULL ; p = p-> next )
359  {
360    if ( p->node_kind & RCONFIG )
361    {
362      if ( !strcmp( p->nentries, "1" ))
363        strcpy( tmp, "" ) ;
364      else
365        strcpy( tmp, "SOURCE_REC_DEX" ) ;
366      fprintf(fp," DEST_RECORD %-26s = SOURCE_RECORD %s %s\n",p->name,p->name,tmp) ;
367    }
368  }
369  close_the_file( fp ) ;
370  return(0) ;
371}
372
373int
374gen_config_reads ( char * dirname )
375{
376  FILE * fp ;
377  int i, n_nml ;
378  char  fname[NAMELEN] ;
379  char * fn = "config_reads.inc" ;
380  char  howset[NAMELEN] ;
381  char *p1, *p2 ;
382  node_t *p ;
383
384  strcpy( fname, fn ) ;
385  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
386  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
387  print_warning(fp,fname) ;
388
389  fprintf(fp,"! Contains namelist statements for module_config.F.\n") ;
390  fprintf(fp,"#ifndef NAMELIST_READ_UNIT\n") ;
391  fprintf(fp,"#  define NAMELIST_READ_UNIT nml_read_unit\n") ;
392  fprintf(fp,"#endif\n") ;
393  fprintf(fp,"#ifndef NAMELIST_WRITE_UNIT\n") ;
394  fprintf(fp,"#  define NAMELIST_WRITE_UNIT nml_write_unit\n") ;
395  fprintf(fp,"#endif\n") ;
396  fprintf(fp,"!\n") ;
397
398  sym_forget() ;
399
400  /*
401     Count how many namelists are defined in the registry
402  */
403  n_nml = 0 ;
404  for ( p = Domain.fields ; p != NULL ; p = p-> next )
405  {
406    if ( p->node_kind & RCONFIG )
407    {
408      strcpy(howset,p->howset) ;
409      p1 = strtok(howset,",") ;
410      p2 = strtok(NULL,",") ;
411      if ( !strcmp(p1,"namelist") )
412      {
413        if (sym_get( p2 ) == NULL)  /* not in table yet */
414        {
415          n_nml ++ ;
416          sym_add(p2) ;
417        }
418      }
419    }
420  }
421
422  sym_forget() ;
423
424  fprintf(fp," nml_read_error = .FALSE.\n") ;
425  fprintf(fp," NML_LOOP : DO i=1,%i\n", n_nml) ;
426  fprintf(fp,"    REWIND ( UNIT = NAMELIST_READ_UNIT )\n") ;
427  fprintf(fp,"    SELECT CASE ( i )\n") ;
428  i = 1;
429  for ( p = Domain.fields ; p != NULL ; p = p-> next )
430  {
431    if ( p->node_kind & RCONFIG )
432    {
433      strcpy(howset,p->howset) ;
434      p1 = strtok(howset,",") ;
435      p2 = strtok(NULL,",") ;
436      if ( !strcmp(p1,"namelist") )
437      {
438        if ( p2 == NULL )
439        {
440          fprintf(stderr,
441          "Warning: no namelist section specified for nl %s\n",p->name) ;
442          continue ;
443        }
444        if (sym_get( p2 ) == NULL)  /* not in table yet */
445        {
446          fprintf(fp,"       CASE ( %i ) \n",i) ;
447          fprintf(fp,"          nml_name = \"%s\"\n",p2) ;
448          fprintf(fp,"          READ   ( UNIT = NAMELIST_READ_UNIT , NML = %s , ERR=9201, END=9202 )\n",p2) ;
449          fprintf(fp,"#ifndef NO_NAMELIST_PRINT\n") ;
450          fprintf(fp,"          WRITE ( UNIT = NAMELIST_WRITE_UNIT, NML = %s )\n",p2) ;
451          fprintf(fp,"#endif\n") ;
452          fprintf(fp,"          CYCLE NML_LOOP\n") ;
453          i ++ ;
454          sym_add(p2) ;
455        }
456      }
457    }
458  }
459  fprintf(fp,"    END SELECT\n") ;
460  fprintf(fp,"9201 CALL wrf_message(\"Error while reading namelist \"//TRIM(nml_name))\n") ;
461  fprintf(fp,"    nml_read_error = .TRUE.\n") ;
462  fprintf(fp,"    CYCLE NML_LOOP\n") ;
463  fprintf(fp,"9202 CALL wrf_message(\"Namelist \"//TRIM(nml_name)//\" not found in namelist.input.\"// & \n") ;
464  fprintf(fp,"                      \" Using registry defaults for variables in \"//TRIM(nml_name))\n") ;
465  fprintf(fp," END DO NML_LOOP\n") ;
466  fprintf(fp," \n") ;
467  fprintf(fp," IF ( nml_read_error ) CALL wrf_error_fatal(\"Errors while reading one or more namelists from namelist.input.\")\n") ;
468
469  close_the_file( fp ) ;
470  return(0) ;
471}
472
Note: See TracBrowser for help on using the repository browser.