tools/gen_interp.c

   1 #include <stdio.h>
   2 #include <stdlib.h>
   3 #include <string.h>
   4 #include <errno.h>
   5
   6 #ifdef _WIN32
   7 #define rindex(X,Y) strrchr(X,Y)
   8 #define index(X,Y) strchr(X,Y)
   9 #endif
  10
  11 #include "protos.h"
  12 #include "registry.h"
  13 #include "data.h"
  14
  15 int as_long(char *str,long *l) {
  16   char *endptr=NULL;
  17
  18   errno=0;
  19   *l=strtol(str,&endptr,10);
  20   if(!endptr || *endptr) return 0;
  21   return 1;
  22 }
  23
  24 int as_finite_double(char *str,double *d) {
  25   char *endptr=NULL;
  26
  27   errno=0;
  28   *d=strtod(str,&endptr);
  29   if(!endptr || *endptr) return 0;
  30   if(*d==*d && *d+1!=*d)
  31     return 1;
  32   else
  33     return 0; /* NaN or infinite */
  34 }
  35
  36 int contains_str( char *s1, char *s2 )
  37 {
  38   int i ;
  39   char *p, *q, *r ;
  40   if ( s2 == NULL || s1 == NULL ) return ( 0 ) ;
  41   if ( *s2 == '\0' || *s1 == '\0' ) return ( 0 ) ;
  42   p = s1 ;
  43   while ( *p ) {
  44     if ((r = (char *)index( p , *s2 )) == NULL ) { return( 0 ) ; }
  45     for ( q = s2 ; *q && *r == *q ; r++ , q++ )  ;
  46     if ( *q == '\0' ) return (1) ;
  47     p++ ;
  48   }
  49   return( 0 ) ;
  50 }
  51
  52 int contains_tok( char *s1, char *s2, char *delims )
  53 {
  54   char *p ;
  55   char tempstr[8092] ;
  56
  57   strcpy( tempstr , s1 ) ;
  58   p = strtok ( tempstr, delims ) ;
  59   while ( p != NULL )
  60   {
  61     if ( !strcmp ( p , s2 ) ) {  return(1) ;}
  62     p = strtok( NULL, delims ) ;
  63   }
  64   return(0) ;
  65 }
  66
  67
  68  /* Had to increase size for SOA from 4*4096 to 4*7000 */
  69 char halo_define[4*7000], halo_use[NAMELEN], halo_id[NAMELEN], x[NAMELEN] ;
  70
  71 /*KAL added this for vertical interpolation */
  72 /*DJW 131202 modified to create files required for vertical interpolation from parent to nest */
  73 int
  74 gen_nest_v_interp ( char * dirname )
  75 {
  76   char * fnlst[] = { "nest_forcedown_interp_vert.inc",
  77                      "nest_interpdown_interp_vert.inc",
  78                      0L };
  79   int down_path[] = { FORCE_DOWN , INTERP_DOWN };
  80   int ipath;
  81   char **fnp ; char *fn;
  82   char fname[NAMELEN];
  83   FILE *fp;
  84
  85   for ( fnp=fnlst , ipath=0 ; *fnp ; fnp++, ipath++ )
  86   {
  87     fn = *fnp;
  88     if ( dirname == NULL ) return(1);
  89     if ( strlen(dirname) > 0 )
  90     { sprintf(fname,"%s/%s",dirname,fn); }
  91     else
  92     { sprintf(fname,"%s",fn); }
  93     if ((fp = fopen( fname, "w" )) == NULL ) return(1);
  94     print_warning(fp,fname);
  95
  96     gen_nest_interp2( fp, Domain.fields, NULL, down_path[ipath], (down_path[ipath]==FORCE_DOWN)?2:2 );
  97
  98     close_the_file(fp);
  99   }
 100   return(0);
 101 }
 102
 103 int
 104 gen_nest_interp ( char * dirname )
 105 {
 106   char * fnlst[] = { "nest_forcedown_interp.inc" , "nest_interpdown_interp.inc" ,
 107                      "nest_feedbackup_interp.inc", "nest_feedbackup_smooth.inc",
 108                      0L } ;
 109   int down_path[] = { FORCE_DOWN , INTERP_DOWN , INTERP_UP, SMOOTH_UP } ;
 110   int ipath ;
 111   char ** fnp ; char * fn ;
 112   char fname[NAMELEN] ;
 113   FILE * fp ;
 114
 115   /*KAL FORCE_DOWN, etc are integers defined in registry.h, so down_path is an array of integers*/
 116
 117   for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
 118   {
 119     fn = *fnp ;
 120     if ( dirname == NULL ) return(1) ;
 121     if ( strlen(dirname) > 0 )
 122      { sprintf(fname,"%s/%s",dirname,fn) ; }
 123     else
 124      { sprintf(fname,"%s",fn) ; }
 125     if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
 126     print_warning(fp,fname) ;
 127
 128 if      ( down_path[ipath] == INTERP_DOWN ) { sprintf(halo_id,"HALO_INTERP_DOWN") ; }
 129 else if ( down_path[ipath] == FORCE_DOWN  ) { sprintf(halo_id,"HALO_FORCE_DOWN") ; }
 130 else if ( down_path[ipath] == INTERP_UP   ) { sprintf(halo_id,"HALO_INTERP_UP") ; }
 131 else if ( down_path[ipath] == SMOOTH_UP   ) { sprintf(halo_id,"HALO_INTERP_SMOOTH") ; }
 132 sprintf(halo_define,"80:") ;
 133 sprintf(halo_use,"") ;
 134       gen_nest_interp1 ( fp , Domain.fields, NULL, down_path[ipath], (down_path[ipath]==FORCE_DOWN)?2:2 ) ;
 135 {
 136   node_t * comm_struct ;
 137   comm_struct = new_node( HALO ) ;
 138   strcpy( comm_struct->name        , halo_id     ) ;
 139   strcpy( comm_struct->use         , halo_use    ) ;
 140   strcpy( comm_struct->comm_define , halo_define ) ;
 141   add_node_to_end( comm_struct , &Halos ) ;
 142 }
 143
 144
 145     close_the_file(fp) ;
 146   }
 147   return(0) ;
 148 }
 149
 150
 151 int
 152 gen_nest_interp1 ( FILE * fp , node_t * node, char * fourdname, int down_path , int use_nest_time_level )
 153 {
 154   int i, ii ;
 155   char * fn = "nest_interp.inc" ;
 156   char fname[NAMELEN] ;
 157   node_t *p, *p1, *dim ;
 158   int d2, d3, xdex, ydex, zdex, nest_mask ;
 159   char ddim[3][2][NAMELEN] ;
 160   char mdim[3][2][NAMELEN] ;
 161   char pdim[3][2][NAMELEN] ;
 162   char ddim2[3][2][NAMELEN] ;
 163   char mdim2[3][2][NAMELEN] ;
 164   char pdim2[3][2][NAMELEN] ;
 165   char nddim[3][2][NAMELEN] ;
 166   char nmdim[3][2][NAMELEN] ;
 167   char npdim[3][2][NAMELEN] ;
 168   char nddim2[3][2][NAMELEN] ;
 169   char nmdim2[3][2][NAMELEN] ;
 170   char npdim2[3][2][NAMELEN] ;
 171   char vname[NAMELEN], vname2[NAMELEN] ;
 172   char tag[NAMELEN], tag2[NAMELEN] ;
 173   char fcn_name[NAMELEN] ;
 174   char xstag[NAMELEN], ystag[NAMELEN] ;
 175   char dexes[NAMELEN] ;
 176   char ndexes[NAMELEN] ;
 177   char *maskstr ;
 178   char *grid ;
 179   char *colon, r[10],tx[80],temp[80],moredims[80] ;
 180   int d ;
 181   double real_store;
 182   long long_store;
 183
 184   for ( p1 = node ;  p1 != NULL ; p1 = p1->next )
 185   {
 186     if ( p1->node_kind & FOURD )
 187     {
 188       if ( p1->members->next ) {
 189         nest_mask = p1->members->next->nest_mask ;
 190       } else {
 191         continue ;
 192       }
 193     }
 194     else
 195     {
 196       nest_mask = p1->nest_mask ;
 197     }
 198     p = p1 ;
 199
 200     if ( nest_mask & down_path )
 201     {
 202         if ( p->ntl > 1 ) { sprintf(tag,"_2") ; sprintf(tag2,"_%d", use_nest_time_level) ; }
 203         else              { sprintf(tag,"")   ; sprintf(tag2,"")                         ; }
 204
 205         /* construct variable name */
 206         if ( p->node_kind & FOURD ) {
 207
 208 sprintf(x, "%s%s", p->name, tag ) ;
 209 if ( ! contains_tok ( halo_define , x , ":," ) ) {
 210  if ( halo_define[strlen(halo_define)-1] == ':' ) { strcat(halo_define,p->name) ; strcat(halo_define,tag) ; }
 211  else                                             { strcat(halo_define,",") ; strcat(halo_define,p->name) ; strcat(halo_define,tag) ; }
 212 }
 213           strcpy(moredims,"") ;
 214           for ( d = 3 ; d < p->ndims ; d++ ) {
 215             sprintf(temp,"idim%d",d-2) ;
 216             strcat(moredims,",") ; strcat(moredims,temp) ;
 217           }
 218           strcat(moredims,",") ;
 219
 220           strcpy(dexes,"grid%sm31,grid%sm32,grid%sm33") ;
 221           sprintf(vname,"%s%s(%s%sitrace)",p->name,tag,dexes,moredims) ;
 222           strcpy(ndexes,"ngrid%sm31,ngrid%sm32,ngrid%sm33") ;
 223           sprintf(vname2,"%s%s(%s%sitrace)",p->name,tag2,ndexes,moredims) ;
 224
 225           if ( down_path & SMOOTH_UP ) {
 226             strcpy( fcn_name , p->members->next->smoothu_fcn_name ) ;
 227           } else {
 228             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) ) ;
 229           }
 230         }
 231         else
 232         {
 233           sprintf(vname,"%s%s",p->name,tag) ;
 234
 235 if ( ! contains_tok ( halo_define , vname  , ":," ) ) {
 236  if ( halo_define[strlen(halo_define)-1] == ':' ) { strcat(halo_define,vname) ; }
 237  else                                             { strcat(halo_define,",") ; strcat(halo_define,vname) ; }
 238 }
 239           sprintf(vname2,"%s%s",p->name,tag2) ;
 240           if ( down_path & SMOOTH_UP ) {
 241             strcpy( fcn_name , p->smoothu_fcn_name ) ;
 242           } else {
 243             strcpy( fcn_name , (down_path & INTERP_UP)?p->interpu_fcn_name:((down_path & FORCE_DOWN)?p->force_fcn_name:p->interpd_fcn_name) ) ;
 244           }
 245         }
 246
 247         if ( p1->node_kind & FOURD ) {
 248           grid = "" ;
 249           set_dim_strs2 ( p->members->next , ddim , mdim , pdim , "c", 1 ) ;
 250           set_dim_strs2 ( p->members->next , ddim2 , mdim2 , pdim2 , "c", 0 ) ;
 251           set_dim_strs2 ( p->members->next , nddim , nmdim , npdim , "n", 1 ) ;
 252           set_dim_strs2 ( p->members->next , nddim2 , nmdim2 , npdim2 , "n", 0 ) ;
 253           zdex = get_index_for_coord( p->members->next , COORD_Z ) ;
 254           xdex = get_index_for_coord( p->members->next , COORD_X ) ;
 255           ydex = get_index_for_coord( p->members->next , COORD_Y ) ;
 256           if ( p->members->next->stag_x ) strcpy( xstag, ".TRUE." ) ; else strcpy( xstag, ".FALSE." ) ;
 257           if ( p->members->next->stag_y ) strcpy( ystag, ".TRUE." ) ; else strcpy( ystag, ".FALSE." ) ;
 258           if ( p->members->next->stag_x && p->members->next->stag_y ) {
 259             maskstr = "_xystag" ;
 260           } else if ( p->stag_x ) {
 261             maskstr = "_xstag" ;
 262           } else if ( p->stag_y ) {
 263             maskstr = "_ystag" ;
 264           } else {
 265             maskstr = "_nostag" ;
 266           }
 267         } else {
 268           grid = "grid%" ;
 269           set_dim_strs2 ( p , ddim , mdim , pdim , "c", 1 ) ;
 270           set_dim_strs2 ( p , ddim2 , mdim2 , pdim2 , "c", 0 ) ;
 271           set_dim_strs2 ( p , nddim , nmdim , npdim , "n", 1 ) ;
 272           set_dim_strs2 ( p , nddim2 , nmdim2 , npdim2 , "n", 0 ) ;
 273           zdex = get_index_for_coord( p , COORD_Z ) ;
 274           xdex = get_index_for_coord( p , COORD_X ) ;
 275           ydex = get_index_for_coord( p , COORD_Y ) ;
 276           if ( p->stag_x ) strcpy( xstag, ".TRUE." ) ; else strcpy( xstag, ".FALSE." ) ;
 277           if ( p->stag_y ) strcpy( ystag, ".TRUE." ) ; else strcpy( ystag, ".FALSE." ) ;
 278           if ( p->stag_x && p->stag_y ) {
 279             maskstr = "_xystag" ;
 280           } else if ( p->stag_x ) {
 281             maskstr = "_xstag" ;
 282           } else if ( p->stag_y ) {
 283             maskstr = "_ystag" ;
 284           } else {
 285             maskstr = "_nostag" ;
 286           }
 287         }
 288
 289         if ( p->node_kind & FOURD )
 290         {
 291             fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",p->name ) ;
 292             for ( d = p->ndims-1 ; d >= 3 ; d-- ) {
 293               strcpy(r,"") ;
 294               range_of_dimension( r, tx, d, p, "config_flags%" ) ;
 295               colon = index(tx,':') ; *colon = ',' ;
 296               sprintf(temp,"idim%d",d-2) ;
 297               strcat(moredims,",") ; strcat(moredims,temp) ;
 298               fprintf(fp,"  DO %s = %s\n",temp,tx) ;
 299             }
 300             fprintf(fp,"IF ( SIZE( %s%s, %d ) * SIZE( %s%s, %d ) .GT. 1", p->name,tag,xdex+1,p->name,tag,ydex+1 ) ;
 301         } else {
 302           if ( !strcmp( fcn_name, "interp_mask_land_field" ) || !strcmp( fcn_name, "interp_mask_water_field" ) ||
 303                !strcmp( fcn_name, "interp_mask_field")       || !strcmp( fcn_name, "interp_mask_soil") ) {
 304             fprintf(fp,"IF ( .TRUE.") ;
 305           } else {
 306             fprintf(fp,"IF ( SIZE( %s%s, %d ) * SIZE( %s%s, %d ) .GT. 1", grid,vname2,xdex+1,grid,vname2,ydex+1 ) ;
 307           }
 308         }
 309         if(p->mp_var)
 310           fprintf(fp," .and. (interp_mp .eqv. .true.)");
 311         fprintf(fp," ) THEN \n");
 312 #if NMM_CORE==1
 313         if(strcasecmp(fcn_name,"nointerp")) {
 314           /* We get here if we are calling any function other than
 315              "NoInterp," a placeholder function that does not
 316              interpolate and only exists to ensure the variable is
 317              allocated on the intermediate domain.  This is a
 318              workaround for a bug in the IBM compiler: when the
 319              interpolation routine is NoInterp, we do not generate the
 320              call.
 321
 322              This workaround is only enabled for the NMM
 323              configurations since the other configurations do not use
 324              the NoInterp placeholder function. */
 325 #endif
 326 fprintf(fp,"CALL %s (  &         \n", fcn_name ) ;
 327
 328 if ( !strcmp( fcn_name, "interp_mask_land_field" ) || !strcmp( fcn_name, "interp_mask_water_field" ) ||
 329      !strcmp( fcn_name, "interp_mask_field")       || !strcmp( fcn_name, "interp_mask_soil") ) {
 330 fprintf(fp,"  ( SIZE( %s%s , %d )*SIZE( %s%s , %d ) .GT. 1 ), & ! special argument needed because %s has bcasts in it\n",
 331                                                        grid,vname2,xdex+1,grid,vname2,ydex+1,fcn_name) ;
 332 }
 333 fprintf(fp,"                  %s%s,   &       ! CD field\n", grid, (p->node_kind & FOURD)?vname:vname2) ;
 334 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
 335                 ddim[0][0], ddim[0][1], ddim[1][0], ddim[1][1], ddim[2][0], ddim[2][1] ) ;
 336 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
 337                 mdim[0][0], mdim[0][1], mdim[1][0], mdim[1][1], mdim[2][0], mdim[2][1] ) ;
 338 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! CD dims\n",
 339                 pdim[0][0], pdim[0][1], pdim2[1][0], pdim2[1][1], pdim[2][0], pdim[2][1] ) ;
 340 if ( ! (down_path  & SMOOTH_UP)  ) {
 341 fprintf(fp,"                  ngrid%%%s,  &   ! ND field\n", vname2) ;
 342 }
 343 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
 344                 nddim[0][0], nddim[0][1], nddim[1][0], nddim[1][1], nddim[2][0], nddim[2][1] ) ;
 345 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
 346                 nmdim[0][0], nmdim[0][1], nmdim[1][0], nmdim[1][1], nmdim[2][0], nmdim[2][1] ) ;
 347 fprintf(fp,"                 %s, %s, %s, %s, %s, %s,   &         ! ND dims\n",
 348                 npdim[0][0], npdim[0][1], npdim2[1][0], npdim2[1][1], npdim[2][0], npdim[2][1] ) ;
 349
 350 if ( ! (down_path  & SMOOTH_UP)  ) {
 351   if ( sw_deref_kludge == 1 ) {
 352 fprintf(fp,"                  config_flags%%shw, ngrid%%imask%s(nims,njms),         &         ! stencil half width\n",maskstr) ;
 353   } else {
 354 fprintf(fp,"                  config_flags%%shw, ngrid%%imask%s,         &         ! stencil half width\n",maskstr) ;
 355   }
 356 }
 357 fprintf(fp,"                  %s, %s,                                                &         ! xstag, ystag\n", xstag, ystag ) ;
 358 fprintf(fp,"                  ngrid%%i_parent_start, ngrid%%j_parent_start,                     &\n") ;
 359 fprintf(fp,"                  ngrid%%parent_grid_ratio, ngrid%%parent_grid_ratio                &\n") ;
 360
 361         {
 362            char tmpstr[NAMELEN], *p1 ;
 363            node_t * nd, * pp  ;
 364            pp = NULL ;
 365            if ( p->node_kind & FOURD ) {
 366              if (  p->members->next ) {
 367                pp = p->members->next ;
 368              }
 369            } else {
 370              pp = p ;
 371            }
 372            if ( pp ) {
 373              strcpy( tmpstr , "" ) ;
 374              if        ( down_path & SMOOTH_UP ) {
 375                strcpy( tmpstr , pp->smoothu_aux_fields ) ;
 376              } else if ( down_path & INTERP_UP ) {
 377                strcpy( tmpstr , pp->interpu_aux_fields ) ;
 378              } else if ( down_path & FORCE_DOWN ) {
 379                /* by default, add the boundary and boundary tendency fields to the arg list */
 380                if ( (! p->node_kind) & FOURD ) {
 381                  sprintf( tmpstr , "%s_b,%s_bt,", pp->name, pp->name )  ;
 382                } else {
 383                  sprintf( tmpstr , "%s_b,%s_bt,", p->name, p->name )  ;
 384                }
 385                strcat( tmpstr , pp->force_aux_fields ) ;
 386              } else if ( down_path & INTERP_DOWN ) {
 387                strcpy( tmpstr , pp->interpd_aux_fields ) ;
 388              }
 389
 390              for ( p1 = strtok(tmpstr,",") ; p1 != NULL ; p1 = strtok(NULL,",") )
 391              {
 392                if(as_long(p1,&long_store)) {
 393                  /* Integer aux in registry (6, 0x5A, 0774, etc.).
 394                     Print in fortran-readable form. */
 395                  fprintf(fp,",%ld &\n",long_store);
 396                } else if(as_finite_double(p1,&real_store)) {
 397                  /* Real aux in registry (3.7, -3.105e+04, etc.).  Print in
 398                     fortran-readable form. */
 399                  fprintf(fp,",%5.9e &\n",real_store);
 400                } else if( (p1[0]=='l' || p1[0]=='L') && p1[1]=='%' && p1[2]!='\0') {
 401                  /* Local variable requested (l%varname). */
 402                  fprintf(fp,",%s &\n",p1+2);
 403                } else if( p1[0]=='@' && p1[1]!='\0' ) {
 404                  /* Local variable requested (@varname). */
 405                  fprintf(fp,",%s &\n",p1+1);
 406                } else if( p1[0]=='*' && p1[1]=='\0' ) {
 407                  /* Entire grid requested (*) */
 408                  fprintf(fp,",grid ,ngrid &\n");
 409                } else if( !strcasecmp(p1,"n%*") ) {
 410                  /* Nest grid requested (n%*) */
 411                  fprintf(fp,",ngrid &\n");
 412                } else if( !strcasecmp(p1,"c%*") ) {
 413                  /* Coarse grid requested (c%*) */
 414                  fprintf(fp,",grid &\n");
 415                } else { /* is n%varname, c%varname, varname or an error */
 416                  int want_nest=1;
 417                  int want_coarse=1;
 418                  char *subvar=p1;
 419                  if( (p1[0]=='n' || p1[0]=='N') && p1[1]=='%' && p1[2]!='\0' ) {
 420                    /* n%var, so we don't want the coarse domain var */
 421                    want_coarse=0;
 422                    subvar+=2;
 423                  } else if( (p1[0]=='c' || p1[0]=='C') && p1[1]=='%' && p1[2]!='\0' ) {
 424                    /* c%var, so we don't want the nest domain var */
 425                    want_nest=0;
 426                    subvar+=2;
 427                  } else {
 428                    /* either "varname" (so we give coarse and nest) or an error */
 429                  }
 430
 431                  if (( nd = get_entry ( subvar , Domain.fields )) != NULL ) {
 432                    /* Variable name is valid */
 433                    if ( nd->boundary_array ) {
 434                      /* We're requesting boundary data, which may need
 435                         to be handled differently, depending on the
 436                         configuration. */
 437                      if ( sw_new_bdys ) {
 438                        int bdy ;
 439                        for ( bdy = 1 ; bdy <= 4 ; bdy++ ) {
 440                          if ( strcmp( nd->use , "_4d_bdy_array_" ) ) {
 441                            if(want_coarse) fprintf(fp,",dummy_%s ",bdy_indicator(bdy));
 442                            if(want_nest)   fprintf(fp,",ngrid%%%s%s ",nd->name, bdy_indicator(bdy));
 443                          } else {
 444                            char c ;
 445                            c = 'i' ; if ( bdy <= 2 ) c = 'j' ;
 446                            if(want_coarse) fprintf(fp,",%s%s(c%cms,1,1,itrace) ", nd->name, bdy_indicator(bdy), c);
 447                            if(want_nest)   fprintf(fp,",ngrid%%%s%s(n%cms,1,1,itrace) ", nd->name, bdy_indicator(bdy), c);
 448                          }
 449                          fprintf(fp,"&\n");
 450                        }
 451                      } else {
 452                        if ( strcmp( nd->use , "_4d_bdy_array_" ) ) {
 453                          if(want_coarse)   fprintf(fp,",%s ", nd->name) ;
 454                          if(want_nest)     fprintf(fp,",ngrid%%%s ", nd->name ) ;
 455                        } else {
 456                          if(want_coarse)   fprintf(fp,",%s(1,1,1,1,itrace) ", nd->name ) ;
 457                          if(want_nest)     fprintf(fp,",ngrid%%%s(1,1,1,1,itrace) ", nd->name ) ;
 458                        }
 459                        fprintf(fp,"&\n");
 460                      }
 461                    } else {
 462                      /* This is not a boundary array, so pass the
 463                         variable. */
 464                      if(want_coarse)       fprintf(fp,",grid%%%s",  nd->name ) ;
 465                      if(want_nest)         fprintf(fp,",ngrid%%%s",  nd->name ) ;
 466                      fprintf(fp,"&\n");
 467                    }
 468                  } else {
 469                    fprintf(stderr,"REGISTRY WARNING: %s: %s is not a variable or number; ignoring it\n",vname,p1) ;
 470                  }
 471                }
 472              }
 473            }
 474         }
 475
 476 fprintf(fp,"                  ) \n") ;
 477 #if NMM_CORE==1
 478         } else {
 479           fprintf(fp,"CONTINUE ! do not call %s\n", fcn_name ) ;
 480         } /* end of "skip this if we would call NoInterp" */
 481 #endif
 482         if ( p->node_kind & FOURD )
 483         {
 484 fprintf(fp,"ENDIF\n") ;
 485             for ( d = p->ndims-1 ; d >= 3 ; d-- ) {
 486 fprintf(fp,"ENDDO\n") ;
 487             }
 488 fprintf(fp,"ENDDO\n") ;
 489         } else {
 490 fprintf(fp,"ENDIF\n") ; /* in_use_from_config */
 491         }
 492
 493      }
 494   }
 495
 496   return(0) ;
 497 }
 498
 499 /* DJW 131202 Modified this to include only variables that have a vertical dimension
 500  * (excluding soil layers and other extra dimensions) and inserts a different
 501  * function call depending on variable staggering in z. */
 502 int
 503 gen_nest_interp2 ( FILE * fp , node_t * node, char * fourdname, int down_path , int use_nest_time_level )
 504 {
 505   node_t *p, *p1 ;
 506   int  xdex, ydex, nest_mask ;
 507   char ddim[3][2][NAMELEN] ;
 508   char mdim[3][2][NAMELEN] ;
 509   char pdim[3][2][NAMELEN] ;
 510   char vname[NAMELEN], vname2[NAMELEN] ;
 511   char tag[NAMELEN], tag2[NAMELEN] ;
 512   char dexes[NAMELEN] ;
 513   char ndexes[NAMELEN] ;
 514   char *grid ;
 515   char *colon,r[10],tx[80],temp[80],moredims[80] ;
 516   int d ;
 517   char zstag[NAMELEN];
 518   char fcn_name[NAMELEN];
 519
 520   for ( p1 = node ;  p1 != NULL ; p1 = p1->next )
 521   {
 522
 523     /* KAL-get the nest mask to see what path the variable is on */
 524     if ( p1->node_kind & FOURD )
 525     {
 526       if ( p1->members->next ) {
 527         nest_mask = p1->members->next->nest_mask ;
 528       } else {
 529         continue ;
 530       }
 531     }
 532     else
 533     {
 534       nest_mask = p1->nest_mask ;
 535     }
 536     p = p1 ;
 537
 538
 539
 540     if ( nest_mask & down_path )
 541     {
 542         /*KAL get the dimensions of the variable and only work on ones with vertical extents*/
 543         if ( p1->node_kind & FOURD ) {
 544           set_dim_strs2 ( p->members->next , ddim , mdim , pdim , "", 1 ) ;
 545         } else {
 546           set_dim_strs2 ( p , ddim , mdim , pdim , "", 1 ) ;
 547         }
 548         if ( !strcmp ( ddim[0][1], "kde") ||
 549                         !strcmp ( ddim[1][1], "kde") ||
 550                         !strcmp ( ddim[2][1], "kde")) {
 551
 552             if ( p->ntl > 1 ) { sprintf(tag,"_2") ; sprintf(tag2,"_%d", use_nest_time_level) ; }
 553             else              { sprintf(tag,"")   ; sprintf(tag2,"")                         ; }
 554
 555             /* construct variable name */
 556             if ( p->node_kind & FOURD ) {
 557               sprintf(x, "%s%s", p->name, tag ) ;
 558               strcpy(moredims,"") ;
 559               for ( d = 3 ; d < p->ndims ; d++ ) {
 560                   sprintf(temp,"idim%d",d-2) ;
 561                   strcat(moredims,",") ; strcat(moredims,temp) ;
 562               }
 563               strcat(moredims,",") ;
 564               strcpy(dexes,"grid%sm31,grid%sm32,grid%sm33") ;
 565               sprintf(vname,"%s%s(%s%sitrace)",p->name,tag,dexes,moredims) ;
 566               strcpy(ndexes,"ngrid%sm31,ngrid%sm32,ngrid%sm33") ;
 567               sprintf(vname2,"%s%s(%s%sitrace)",p->name,tag2,ndexes,moredims) ;
 568             }
 569             else
 570             {
 571               sprintf(vname,"%s%s",p->name,tag) ;
 572               sprintf(vname2,"%s%s",p->name,tag2) ;
 573             }
 574
 575             if ( p1->node_kind & FOURD ) {
 576               grid = "" ;
 577               xdex = get_index_for_coord( p->members->next , COORD_X ) ;
 578               ydex = get_index_for_coord( p->members->next , COORD_Y ) ;
 579             } else {
 580               grid = "grid%" ;
 581               xdex = get_index_for_coord( p , COORD_X ) ;
 582               ydex = get_index_for_coord( p , COORD_Y ) ;
 583             }
 584
 585             if ( p->stag_z ) {
 586                 strcpy( zstag, ".TRUE." );
 587                 strcpy(fcn_name,"vert_interp_vert_nesting_w");
 588             } else {
 589                 strcpy( zstag, ".FALSE." );
 590                 strcpy(fcn_name,"vert_interp_vert_nesting");
 591             }
 592
 593  /* DJW 131202 The condition for the if-statement below is really really poorly written.
 594   * I'm attempting to say "if the variable has a vertical dimension that spans multiple
 595   * eta levels. Note that this is complicated because some variables have a vertical
 596   * dimension that describes the number of soil levels they use. There are also other
 597   * vertical dimensions that we need be wary of... hence my hack to make this work since
 598   * at the moment all the variables I want to interpolate have kde points in the vertical!*/
 599             if ( strcmp("kde",ddim[1][1]) == 0 ) {
 600                 if ( p->node_kind & FOURD ) {
 601                     fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",p->name ) ;
 602                     for ( d = p->ndims-1 ; d >= 3 ; d-- ) {
 603                     strcpy(r,"") ;
 604                     range_of_dimension( r, tx, d, p, "config_flags%" ) ;
 605                     colon = index(tx,':') ; *colon = ',' ;
 606                     sprintf(temp,"idim%d",d-2) ;
 607                     strcat(moredims,",") ; strcat(moredims,temp) ;
 608                     fprintf(fp,"  DO %s = %s\n",temp,tx) ;
 609                     }
 610                     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 ) ;
 611                 } else {
 612                     fprintf(fp,"IF ( SIZE( %s%s, %d ) * SIZE( %s%s, %d ) .GT. 1 ) THEN \n", grid,vname2,xdex+1,grid,vname2,ydex+1 ) ;
 613                 }
 614
 615                 fprintf(fp,"    CALL %s( &\n",fcn_name);
 616                 fprintf(fp,"                                  %s%s, & !CD field\n",grid,(p->node_kind & FOURD)?vname:vname2);
 617                 fprintf(fp,"                                  %s, %s, %s, %s, %s, %s, & !CD dims\n",ddim[0][0],ddim[0][1],ddim[1][0],ddim[1][1],ddim[2][0],ddim[2][1]);
 618                 fprintf(fp,"                                  %s, %s, %s, %s, %s, %s, & !CD dims\n",mdim[0][0],mdim[0][1],mdim[1][0],mdim[1][1],mdim[2][0],mdim[2][1]);
 619                 fprintf(fp,"                                  %s, %s, %s, MIN( (%s-1), %s ), %s, %s, & !CD dims\n",pdim[0][0],pdim[0][1],pdim[1][0],ddim[1][1],pdim[1][1],pdim[2][0],pdim[2][1]);
 620                 fprintf(fp,"                                  pgrid%%s_vert, pgrid%%e_vert, & !vertical dimension of the parent grid\n");
 621                 if ( strcmp(zstag,".TRUE.") != 0 ) {
 622                     fprintf(fp,"                                  pgrid%%cf1, pgrid%%cf2, pgrid%%cf3, pgrid%%cfn, pgrid%%cfn1, & !coarse grid extrapolation constants\n");
 623                     fprintf(fp,"                                  alt_u_c, alt_u_n ) !coordinates for parent and nest\n");
 624                 } else {
 625                     fprintf(fp,"                                  alt_w_c, alt_w_n ) !coordinates for parent and nest\n");
 626                 }
 627
 628                 if ( p->node_kind & FOURD )
 629                 {
 630                     fprintf(fp,"ENDIF\n") ;
 631                     for ( d = p->ndims-1 ; d >= 3 ; d-- ) {
 632                         fprintf(fp,"ENDDO\n") ;
 633                     }
 634                     fprintf(fp,"ENDDO\n") ;
 635                 } else {
 636                     fprintf(fp,"ENDIF\n") ; /* in_use_from_config */
 637                 }
 638             } /* end of if variable has > 1 vertical level*/
 639         } /* end of if variable has vertical dimension*/
 640      } /* end of mask for down_path*/
 641   } /*end of loop over nodes*/
 642   return(0) ;
 643 }
 644