wrfv2_fire/tools/gen_config.c

   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_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
 227 int
 228 gen_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
 267 int
 268 gen_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