source: lmdz_wrf/trunk/WRFV3/tools/gen_config.c @ 2367

Last change on this file since 2367 was 1, checked in by lfita, 11 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

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