source: trunk/WRF.COMMON/WRFV2/tools/gen_config.c @ 3667

Last change on this file since 3667 was 11, checked in by aslmd, 15 years ago

spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 10.1 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_get_nl_config ( char * dirname )
120{
121  FILE * fp ;
122  char  fname[NAMELEN] ;
123  char * fn = "get_nl_config.inc" ;
124  char * gs, * intnt ;
125  char  howset[NAMELEN] ;
126  node_t *p ;
127  int sw ;
128
129
130  strcpy( fname, fn ) ;
131  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
132  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
133  print_warning(fp,fname) ;
134
135  for ( sw = 0 ; sw < 2 ; sw++ ) 
136  {
137  if ( sw == 0 ) { gs = "get" ; intnt = "OUT" ; } else { gs = "set" ; intnt = "IN" ; }
138  for ( p = Domain.fields ; p != NULL ; p = p-> next )
139  {
140    if ( p->node_kind & RCONFIG )
141    {
142      strcpy(howset,p->howset) ;
143      fprintf(fp,"SUBROUTINE nl_%s_%s ( id_id , %s )\n",gs,p->name, p->name) ;
144      if ( sw_ifort_kludge ) {
145        fprintf(fp,"  USE module_configure\n") ;
146      }
147      fprintf(fp,"  %s , INTENT(%s) :: %s\n",p->type->name,intnt,p->name) ;
148      fprintf(fp,"  INTEGER id_id\n") ;
149      fprintf(fp,"  CHARACTER*80 emess\n") ;
150      if ( sw == 0 ) /* get */
151      {
152        if ( !strcmp( p->nentries, "1" )) {
153          if ( ! sw_ifort_kludge ) {
154            fprintf(fp,"  IF ( id_id .NE. 1 ) THEN\n") ;
155            fprintf(fp,"    call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n",
156                            gs,p->name, p->name ) ;
157            fprintf(fp,"  ENDIF\n" ) ;
158          }
159          if ( !strncmp(p->type->name,"character",9)) {
160            fprintf(fp,"  %s = trim(model_config_rec%%%s)\n",p->name,p->name) ;
161          }else{
162            fprintf(fp,"  %s = model_config_rec%%%s\n",p->name,p->name) ;
163          }
164        } else {
165          if ( ! sw_ifort_kludge ) {
166            if        ( !strcmp( p->nentries, "max_domains" )) {
167              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ;
168              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ;
169            } else if ( !strcmp( p->nentries, "max_moves" )) {
170              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ;
171              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ;
172            } else if ( !strcmp( p->nentries, "max_eta" )) {
173              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ;
174              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ;
175            } else {
176              fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, or max_eta \n") ;
177            }
178            fprintf(fp,"    CALL wrf_error_fatal(emess)\n") ;
179            fprintf(fp,"  ENDIF\n" ) ;
180          }
181          fprintf(fp,"  %s = model_config_rec%%%s(id_id)\n",p->name,p->name) ;
182        }
183      }
184      else   /* set */
185      {
186        if ( !strcmp( p->nentries, "1" )) {
187          if ( ! sw_ifort_kludge ) {
188            fprintf(fp,"  IF ( id_id .NE. 1 ) THEN\n") ;
189            fprintf(fp,"    call wrf_debug(1,&\n'WARNING in nl_%s_%s: %s applies to all domains. First arg ignored.')\n",
190                            gs,p->name, p->name ) ;
191            fprintf(fp,"  ENDIF\n" ) ;
192          }
193          if ( !strncmp(p->type->name,"character",9)) {
194            fprintf(fp,"  model_config_rec%%%s = trim(%s) \n",p->name,p->name) ;
195          }else{
196            fprintf(fp,"  model_config_rec%%%s = %s \n",p->name,p->name) ;
197          }
198        } else {
199          if ( ! sw_ifort_kludge ) {
200            if        ( !strcmp( p->nentries, "max_domains" )) {
201              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%max_dom ) THEN\n") ;
202              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range domain number: ',id_id\n",gs,p->name) ;
203            } else if ( !strcmp( p->nentries, "max_moves" )) {
204              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%num_moves ) THEN\n") ;
205              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range move number: ',id_id\n",gs,p->name) ;
206            } else if ( !strcmp( p->nentries, "max_eta" )) {
207              fprintf(fp,"  IF ( id_id .LT. 1 .OR. id_id .GT. model_config_rec%%e_vert(1) ) THEN\n") ;
208              fprintf(fp,"    WRITE(emess,*)'nl_%s_%s: Out of range eta_level number: ',id_id\n",gs,p->name) ;
209            } else {
210              fprintf(stderr,"Registry WARNING: multi element rconfig entry must be either max_domains, max_moves, or max_eta \n") ;
211            }
212            fprintf(fp,"    CALL wrf_error_fatal(emess)\n") ;
213            fprintf(fp,"  ENDIF\n" ) ;
214          }
215          fprintf(fp,"  model_config_rec%%%s(id_id) = %s\n",p->name,p->name) ;
216        }
217      }
218      fprintf(fp,"  RETURN\n") ;
219      fprintf(fp,"END SUBROUTINE nl_%s_%s\n",gs,p->name ) ;
220    }
221  }
222  }
223  close_the_file( fp ) ;
224  return(0) ;
225}
226
227int
228gen_config_assigns ( char * dirname )
229{
230  FILE * fp ;
231  char  fname[NAMELEN] ;
232  char * fn = "config_assigns.inc" ;
233  char  tmp[NAMELEN] ;
234  node_t *p ;
235
236  strcpy( fname, fn ) ;
237  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
238  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
239  print_warning(fp,fname) ;
240
241  fprintf(fp,"! Contains config assign statements for module_domain.F.\n") ;
242  fprintf(fp,"#ifndef SOURCE_RECORD\n") ;
243  fprintf(fp,"#  define SOURCE_RECORD cfg%%\n") ;
244  fprintf(fp,"#endif\n") ;
245  fprintf(fp,"#ifndef SOURCE_REC_DEX\n") ;
246  fprintf(fp,"#  define SOURCE_REC_DEX\n") ;
247  fprintf(fp,"#endif\n") ;
248  fprintf(fp,"#ifndef DEST_RECORD\n") ;
249  fprintf(fp,"#  define DEST_RECORD new_grid%%\n") ;
250  fprintf(fp,"#endif\n") ;
251
252  for ( p = Domain.fields ; p != NULL ; p = p-> next )
253  {
254    if ( p->node_kind & RCONFIG )
255    {
256      if ( !strcmp( p->nentries, "1" ))
257        strcpy( tmp, "" ) ;
258      else
259        strcpy( tmp, "SOURCE_REC_DEX" ) ;
260      fprintf(fp," DEST_RECORD %-26s = SOURCE_RECORD %s %s\n",p->name,p->name,tmp) ;
261    }
262  }
263  close_the_file( fp ) ;
264  return(0) ;
265}
266
267int
268gen_config_reads ( char * dirname )
269{
270  FILE * fp ;
271  char  fname[NAMELEN] ;
272  char * fn = "config_reads.inc" ;
273  char  howset[NAMELEN] ;
274  char *p1, *p2 ;
275  node_t *p ;
276
277  strcpy( fname, fn ) ;
278  if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
279  if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
280  print_warning(fp,fname) ;
281
282  fprintf(fp,"! Contains namelist statements for module_config.F.\n") ;
283  fprintf(fp,"#ifndef NAMELIST_READ_UNIT\n") ;
284  fprintf(fp,"#  define NAMELIST_READ_UNIT nml_unit\n") ;
285  fprintf(fp,"#endif\n") ;
286  fprintf(fp,"#ifndef NAMELIST_READ_ERROR_LABEL\n") ;
287  fprintf(fp,"#  define NAMELIST_READ_ERROR_LABEL 9200\n") ;
288  fprintf(fp,"#endif\n") ;
289  fprintf(fp,"!\n") ;
290
291  sym_forget() ;
292
293  for ( p = Domain.fields ; p != NULL ; p = p-> next )
294  {
295    if ( p->node_kind & RCONFIG )
296    {
297      strcpy(howset,p->howset) ;
298      p1 = strtok(howset,",") ;
299      p2 = strtok(NULL,",") ;
300      if ( !strcmp(p1,"namelist") )
301      {
302        if ( p2 == NULL )
303        {
304          fprintf(stderr,
305          "Warning: no namelist section specified for nl %s\n",p->name) ;
306          continue ;
307        }
308        if (sym_get( p2 ) == NULL)  /* not in table yet */
309        {
310          fprintf(fp," REWIND  ( UNIT = NAMELIST_READ_UNIT )\n") ;
311          fprintf(fp," READ  ( UNIT = NAMELIST_READ_UNIT , NML = %s , ERR = NAMELIST_READ_ERROR_LABEL , END = NAMELIST_READ_ERROR_LABEL )\n",p2) ;
312          fprintf(fp,"#ifndef NO_NAMELIST_PRINT\n") ;
313          fprintf(fp," WRITE ( UNIT = *                  , NML = %s )\n",p2) ;
314          fprintf(fp,"#endif\n") ;
315          sym_add(p2) ;
316        }
317       
318      }
319    }
320  }
321  close_the_file( fp ) ;
322  return(0) ;
323}
324
Note: See TracBrowser for help on using the repository browser.