wrfv2_fire/tools/gen_interp.c

   1 #include <stdio.h>
   2 #include <stdlib.h>
   3 #include <string.h>
   4
   5 #ifdef _WIN32
   6 #define rindex(X,Y) strrchr(X,Y)
   7 #define index(X,Y) strchr(X,Y)
   8 #endif
   9
  10 #include "protos.h"
  11 #include "registry.h"
  12 #include "data.h"
  13
  14 int contains_str( char *s1, char *s2 )
  15 {
  16   int i ;
  17   char *p, *q, *r ;
  18   if ( s2 == NULL || s1 == NULL ) return ( 0 ) ;
  19   if ( *s2 == '\0' || *s1 == '\0' ) return ( 0 ) ;
  20   p = s1 ;
  21   while ( *p ) {
  22     if ((r = (char *)index( p , *s2 )) == NULL ) { return( 0 ) ; }
  23     for ( q = s2 ; *q && *r == *q ; r++ , q++ )  ;
  24     if ( *q == '\0' ) return (1) ;
  25     p++ ;
  26   }
  27   return( 0 ) ;
  28 }
  29
  30 int contains_tok( char *s1, char *s2, char *delims )
  31 {
  32   char *p ;
  33   char tempstr[8092] ;
  34
  35   strcpy( tempstr , s1 ) ;
  36   p = strtok ( tempstr, delims ) ;
  37   while ( p != NULL )
  38   {
  39     if ( !strcmp ( p , s2 ) ) {  return(1) ;}
  40     p = strtok( NULL, delims ) ;
  41   }
  42   return(0) ;
  43 }
  44
  45
  46 char halo_define[4*4096], halo_use[NAMELEN], halo_id[NAMELEN], x[NAMELEN] ;
  47
  48 int
  49 gen_nest_interp ( char * dirname )
  50 {
  51   char * fnlst[] = { "nest_forcedown_interp.inc" , "nest_interpdown_interp.inc" ,
  52                      "nest_feedbackup_interp.inc", "nest_feedbackup_smooth.inc",
  53                      0L } ;
  54   int down_path[] = { FORCE_DOWN , INTERP_DOWN , INTERP_UP, SMOOTH_UP } ;
  55   int ipath ;
  56   char ** fnp ; char * fn ;
  57   char fname[NAMELEN] ;
  58   FILE * fp ;
  59
  60   for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
  61   {
  62     fn = *fnp ;
  63     if ( dirname == NULL ) return(1) ;
  64     if ( strlen(dirname) > 0 )
  65      { sprintf(fname,"%s/%s",dirname,fn) ; }
  66     else
  67      { sprintf(fname,"%s",fn) ; }
  68     if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
  69     print_warning(fp,fname) ;
  70
  71 if      ( down_path[ipath] == INTERP_DOWN ) { sprintf(halo_id,"HALO_INTERP_DOWN") ; }
  72 else if ( down_path[ipath] == FORCE_DOWN  ) { sprintf(halo_id,"HALO_FORCE_DOWN") ; }
  73 else if ( down_path[ipath] == INTERP_UP   ) { sprintf(halo_id,"HALO_INTERP_UP") ; }
  74 else if ( down_path[ipath] == SMOOTH_UP   ) { sprintf(halo_id,"HALO_INTERP_SMOOTH") ; }
  75 sprintf(halo_define,"80:") ;
  76 sprintf(halo_use,"") ;
  77       gen_nest_interp1 ( fp , Domain.fields, NULL, down_path[ipath], (down_path[ipath]==FORCE_DOWN)?2:2 ) ;
  78 {
  79   node_t * comm_struct ;
  80   comm_struct = new_node( HALO ) ;
  81   strcpy( comm_struct->name        , halo_id     ) ;
  82   strcpy( comm_struct->use         , halo_use    ) ;
  83   strcpy( comm_struct->comm_define , halo_define ) ;
  84   add_node_to_end( comm_struct , &Halos ) ;
  85 }
  86
  87
  88     close_the_file(fp) ;
  89   }
  90   return(0) ;
  91 }
  92
  93
  94 int
  95 gen_nest_interp1 ( FILE * fp , node_t * node, char * fourdname, int down_path , int use_nest_time_level )
  96 {
  97   int i, ii ;
  98   char * fn = "nest_interp.inc" ;
  99   char fname[NAMELEN] ;
 100   node_t *p, *p1, *dim ;
 101   int d2, d3, xdex, ydex, zdex, nest_mask ;
 102   char ddim[3][2][NAMELEN] ;
 103   char mdim[3][2][NAMELEN] ;
 104   char pdim[3][2][NAMELEN] ;
 105   char ddim2[3][2][NAMELEN] ;
 106   char mdim2[3][2][NAMELEN] ;
 107   char pdim2[3][2][NAMELEN] ;
 108   char nddim[3][2][NAMELEN] ;
 109   char nmdim[3][2][NAMELEN] ;
 110   char npdim[3][2][NAMELEN] ;
 111   char nddim2[3][2][NAMELEN] ;
 112   char nmdim2[3][2][NAMELEN] ;
 113   char npdim2[3][2][NAMELEN] ;
 114   char vname[NAMELEN], vname2[NAMELEN] ;
 115   char tag[NAMELEN], tag2[NAMELEN] ;
 116   char fcn_name[NAMELEN] ;
 117   char xstag[NAMELEN], ystag[NAMELEN] ;
 118   char dexes[NAMELEN] ;
 119   char ndexes[NAMELEN] ;
 120   char *maskstr ;
 121   char *grid ;
 122   char *colon, r[10],tx[80],temp[80],moredims[80] ;
 123   int d ;
 124
 125
 126   for ( p1 = node ;  p1 != NULL ; p1 = p1->next )
 127   {
 128     if ( p1->node_kind & FOURD )
 129     {
 130       if ( p1->members->next ) {
 131         nest_mask = p1->members->next->nest_mask ;
 132       } else {
 133         continue ;
 134       }
 135     }
 136     else
 137     {
 138       nest_mask = p1->nest_mask ;
 139     }
 140     p = p1 ;
 141
 142     if ( nest_mask & down_path )
 143     {
 144         if ( p->ntl > 1 ) { sprintf(tag,"_2") ; sprintf(tag2,"_%d", use_nest_time_level) ; }
 145         else              { sprintf(tag,"")   ; sprintf(tag2,"")                         ; }
 146
 147         /* construct variable name */
 148         if ( p->node_kind & FOURD ) {
 149
 150 sprintf(x, "%s%s", p->name, tag ) ;
 151 if ( ! contains_tok ( halo_define , x , ":," ) ) {
 152  if ( halo_define[strlen(halo_define)-1] == ':' ) { strcat(halo_define,p->name) ; strcat(halo_define,tag) ; }
 153  else                                             { strcat(halo_define,",") ; strcat(halo_define,p->name) ; strcat(halo_define,tag) ; }
 154 }
 155           strcpy(moredims,"") ;
 156           for ( d = 3 ; d < p->ndims ; d++ ) {
 157             sprintf(temp,"idim%d",d-2) ;
 158             strcat(moredims,",") ; strcat(moredims,temp) ;
 159           }
 160           strcat(moredims,",") ;
 161
 162           strcpy(dexes,"grid%sm31,grid%sm32,grid%sm33") ;
 163           sprintf(vname,"%s%s(%s%sitrace)",p->name,tag,dexes,moredims) ;
 164           strcpy(ndexes,"ngrid%sm31,ngrid%sm32,ngrid%sm33") ;
 165           sprintf(vname2,"%s%s(%s%sitrace)",p->name,tag2,ndexes,moredims) ;
 166
 167           if ( down_path & SMOOTH_UP ) {
 168             strcpy( fcn_name , p->members->next->smoothu_fcn_name ) ;
 169           } else {
 170             strcpy( fcn_name , (down_path & INTERP_UP)?p->members->next->interpu_fcn_name:((down_path & FORCE_DOWN)?p->members->next->force_fcn_name:p->members->next->interpd_fcn_name) ) ;
 171           }
 172         }
 173         else
 174         {
 175           sprintf(vname,"%s%s",p->name,tag) ;
 176
 177 if ( ! contains_tok ( halo_define , vname  , ":," ) ) {
 178  if ( halo_define[strlen(halo_define)-1] == ':' ) { strcat(halo_define,vname) ; }
 179  else                                             { strcat(halo_define,",") ; strcat(halo_define,vname) ; }
 180 }
 181           sprintf(vname2,"%s%s",p->name,tag2) ;
 182           if ( down_path & SMOOTH_UP ) {
 183             strcpy( fcn_name , p->smoothu_fcn_name ) ;
 184           } else {
 185             strcpy( fcn_name , (down_path & INTERP_UP)?p->interpu_fcn_name:((down_path & FORCE_DOWN)?p->force_fcn_name:p->interpd_fcn_name) ) ;
 186           }
 187         }
 188
 189         if ( p1->node_kind & FOURD ) {
 190           grid = "" ;
 191           set_dim_strs2 ( p->members->next , ddim , mdim , pdim , "c", 1 ) ;
 192           set_dim_strs2 ( p->members->next , ddim2 , mdim2 , pdim2 , "c", 0 ) ;
 193           set_dim_strs2 ( p->members->next , nddim , nmdim , npdim , "n", 1 ) ;
 194           set_dim_strs2 ( p->members->next , nddim2 , nmdim2 , npdim2 , "n", 0 ) ;
 195           zdex = get_index_for_coord( p->members->next , COORD_Z ) ;
 196           xdex = get_index_for_coord( p->members->next , COORD_X ) ;
 197           ydex = get_index_for_coord( p->members->next , COORD_Y ) ;
 198           if ( p->members->next->stag_x ) strcpy( xstag, ".TRUE." ) ; else strcpy( xstag, ".FALSE." ) ;
 199           if ( p->members->next->stag_y ) strcpy( ystag, ".TRUE." ) ; else strcpy( ystag, ".FALSE." ) ;
 200           if ( p->members->next->stag_x && p->members->next->stag_y ) {
 201             maskstr = "_xystag" ;
 202           } else if ( p->stag_x ) {
 203             maskstr = "_xstag" ;
 204           } else if ( p->stag_y ) {
 205             maskstr = "_ystag" ;
 206           } else {
 207             maskstr = "_nostag" ;
 208           }
 209         } else {
 210           grid = "grid%" ;
 211           set_dim_strs2 ( p , ddim , mdim , pdim , "c", 1 ) ;
 212           set_dim_strs2 ( p , ddim2 , mdim2 , pdim2 , "c", 0 ) ;
 213           set_dim_strs2 ( p , nddim , nmdim , npdim , "n", 1 ) ;
 214           set_dim_strs2 ( p , nddim2 , nmdim2 , npdim2 , "n", 0 ) ;
 215           zdex = get_index_for_coord( p , COORD_Z ) ;
 216           xdex = get_index_for_coord( p , COORD_X ) ;
 217           ydex = get_index_for_coord( p , COORD_Y ) ;
 218           if ( p->stag_x ) strcpy( xstag, ".TRUE." ) ; else strcpy( xstag, ".FALSE." ) ;
 219           if ( p->stag_y ) strcpy( ystag, ".TRUE." ) ; else strcpy( ystag, ".FALSE." ) ;
 220           if ( p->stag_x && p->stag_y ) {
 221             maskstr = "_xystag" ;
 222           } else if ( p->stag_x ) {
 223             maskstr = "_xstag" ;
 224           } else if ( p->stag_y ) {
 225             maskstr = "_ystag" ;
 226           } else {
 227             maskstr = "_nostag" ;
 228           }
 229         }
 230
 231         if ( p->node_kind & FOURD )
 232         {
 233             fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",p->name ) ;
 234             for ( d = p->ndims-1 ; d >= 3 ; d-- ) {
 235               strcpy(r,"") ;
 236               range_of_dimension( r, tx, d, p, "config_flags%" ) ;
 237               colon = index(tx,':') ; *colon = ',' ;
 238               sprintf(temp,"idim%d",d-2) ;
 239               strcat(moredims,",") ; strcat(moredims,temp) ;
 240               fprintf(fp,"  DO %s = %s\n",temp,tx) ;
 241             }
 242             fprintf(fp,"IF ( SIZE( %s%s, %d ) * SIZE( %s%s, %d ) .GT. 1 ) THEN \n", p->name,tag,xdex+1,p->name,tag,ydex+1 ) ;
 243         } else {
 244           if ( !strcmp( fcn_name, "interp_mask_land_field" ) ||
 245               !strcmp( fcn_name, "interp_mask_water_field" ) ) {
 246             fprintf(fp,"IF ( .TRUE. ) THEN \n") ;
 247           } else {
 248             fprintf(fp,"IF ( SIZE( %s%s, %d ) * SIZE( %s%s, %d ) .GT. 1 ) THEN \n", grid,vname2,xdex+1,grid,vname2,ydex+1 ) ;
 249           }
 250         }
 251
 252 fprintf(fp,"CALL %s (  &         \n", fcn_name ) ;
 253
 254 if ( !strcmp( fcn_name, "interp_mask_land_field" ) || !strcmp( fcn_name, "interp_mask_water_field" ) ) {
 255 fprintf(fp,"  ( SIZE( %s%s , %d )*SIZE( %s%s , %d ) .GT. 1 ), & ! special argument needed because %s has bcasts in it\n",
 256                                                        grid,vname2,xdex+1,grid,vname2,ydex+1,fcn_name) ;
 257 }
 258 fprintf(fp,"                  %s%s,   &       ! CD field\n", grid, (p->node_kind & FOURD)?vname:vname2) ;
 259 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
 260                 ddim[0][0], ddim[0][1], ddim[1][0], ddim[1][1], ddim[2][0], ddim[2][1] ) ;
 261 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
 262                 mdim[0][0], mdim[0][1], mdim[1][0], mdim[1][1], mdim[2][0], mdim[2][1] ) ;
 263 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
 264                 pdim[0][0], pdim[0][1], pdim2[1][0], pdim2[1][1], pdim[2][0], pdim[2][1] ) ;
 265 if ( ! (down_path  & SMOOTH_UP)  ) {
 266 fprintf(fp,"                  ngrid%%%s,  &   ! ND field\n", vname2) ;
 267 }
 268 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
 269                 nddim[0][0], nddim[0][1], nddim[1][0], nddim[1][1], nddim[2][0], nddim[2][1] ) ;
 270 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
 271                 nmdim[0][0], nmdim[0][1], nmdim[1][0], nmdim[1][1], nmdim[2][0], nmdim[2][1] ) ;
 272 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
 273                 npdim[0][0], npdim[0][1], npdim2[1][0], npdim2[1][1], npdim[2][0], npdim[2][1] ) ;
 274
 275 if ( ! (down_path  & SMOOTH_UP)  ) {
 276   if ( sw_deref_kludge == 1 ) {
 277 fprintf(fp,"                  config_flags%%shw, ngrid%%imask%s(nims,njms),         &         ! stencil half width\n",maskstr) ;
 278   } else {
 279 fprintf(fp,"                  config_flags%%shw, ngrid%%imask%s,         &         ! stencil half width\n",maskstr) ;
 280   }
 281 }
 282 fprintf(fp,"                  %s, %s,                                                &         ! xstag, ystag\n", xstag, ystag ) ;
 283 fprintf(fp,"                  ngrid%%i_parent_start, ngrid%%j_parent_start,                     &\n") ;
 284 fprintf(fp,"                  ngrid%%parent_grid_ratio, ngrid%%parent_grid_ratio                &\n") ;
 285
 286         {
 287            char tmpstr[NAMELEN], *p1 ;
 288            node_t * nd, * pp  ;
 289            pp = NULL ;
 290            if ( p->node_kind & FOURD ) {
 291              if (  p->members->next ) {
 292                pp = p->members->next ;
 293              }
 294            } else {
 295              pp = p ;
 296            }
 297            if ( pp ) {
 298              strcpy( tmpstr , "" ) ;
 299              if        ( down_path & SMOOTH_UP ) {
 300                strcpy( tmpstr , pp->smoothu_aux_fields ) ;
 301              } else if ( down_path & INTERP_UP ) {
 302                strcpy( tmpstr , pp->interpu_aux_fields ) ;
 303              } else if ( down_path & FORCE_DOWN ) {
 304                /* by default, add the boundary and boundary tendency fields to the arg list */
 305                if ( ! p->node_kind & FOURD ) {
 306                  sprintf( tmpstr , "%s_b,%s_bt,", pp->name, pp->name )  ;
 307                } else {
 308                  sprintf( tmpstr , "%s_b,%s_bt,", p->name, p->name )  ;
 309                }
 310                strcat( tmpstr , pp->force_aux_fields ) ;
 311              } else if ( down_path & INTERP_DOWN ) {
 312                strcpy( tmpstr , pp->interpd_aux_fields ) ;
 313              }
 314
 315              for ( p1 = strtok(tmpstr,",") ; p1 != NULL ; p1 = strtok(NULL,",") )
 316              {
 317                if (( nd = get_entry ( p1 , Domain.fields )) != NULL )
 318                {
 319                  if ( nd->boundary_array ) {
 320                    if ( sw_new_bdys ) {
 321                      int bdy ;
 322                      for ( bdy = 1 ; bdy <= 4 ; bdy++ ) {
 323                        if ( strcmp( nd->use , "_4d_bdy_array_" ) ) {
 324 #if 0
 325                          fprintf(fp,",%s%s,ngrid%%%s%s  &\n", nd->name, bdy_indicator(bdy), nd->name, bdy_indicator(bdy) ) ;
 326 #else
 327                          fprintf(fp,",dummy_%s,ngrid%%%s%s  &\n",
 328                                      bdy_indicator(bdy),
 329                                      nd->name, bdy_indicator(bdy) ) ;
 330 #endif
 331                        } else {
 332                          char c ;
 333                          c = 'i' ; if ( bdy <= 2 ) c = 'j' ;
 334                          fprintf(fp,",%s%s(c%cms,1,1,itrace),ngrid%%%s%s(n%cms,1,1,itrace)  &\n",
 335                                            nd->name, bdy_indicator(bdy), c,
 336                                            nd->name, bdy_indicator(bdy), c  ) ;
 337                        }
 338                      }
 339                    } else {
 340                      if ( strcmp( nd->use , "_4d_bdy_array_" ) ) {
 341                        fprintf(fp,",%s,ngrid%%%s  &\n", nd->name, nd->name ) ;
 342                      } else {
 343                        fprintf(fp,",%s(1,1,1,1,itrace),ngrid%%%s(1,1,1,1,itrace)  &\n", nd->name, nd->name ) ;
 344                      }
 345                    }
 346                  } else {
 347                    fprintf(fp,",grid%%%s,ngrid%%%s  &\n",  nd->name,  nd->name ) ;
 348                  }
 349                }
 350                else
 351                {
 352                  fprintf(stderr,"REGISTRY WARNING: Don't know about %s in definition of %s\n",p1,vname) ;
 353                }
 354              }
 355            }
 356         }
 357
 358 fprintf(fp,"                  ) \n") ;
 359
 360         if ( p->node_kind & FOURD )
 361         {
 362 fprintf(fp,"ENDIF\n") ;
 363             for ( d = p->ndims-1 ; d >= 3 ; d-- ) {
 364 fprintf(fp,"ENDDO\n") ;
 365             }
 366 fprintf(fp,"ENDDO\n") ;
 367         } else {
 368 fprintf(fp,"ENDIF\n") ; /* in_use_from_config */
 369         }
 370
 371      }
 372   }
 373
 374   return(0) ;
 375 }
 376