tools/gen_allocs.c

   1 #include <stdio.h>
   2 #include <stdlib.h>
   3 #include <string.h>
   4 #ifndef _WIN32
   5 # include <strings.h>
   6 #endif
   7
   8 #include "protos.h"
   9 #include "registry.h"
  10 #include "data.h"
  11 #include "sym.h"
  12
  13 int
  14 gen_alloc ( char * dirname )
  15 {
  16   gen_alloc1( dirname ) ;
  17   gen_ddt_write( dirname ) ;
  18   return(0) ;
  19 }
  20
  21 int
  22 get_count_for_alloc( node_t *node , int *numguys, int *stats)  ;  /* forward */
  23
  24 int
  25 gen_alloc1 ( char * dirname )
  26 {
  27   FILE * fp ;
  28   FILE * fpCalls ;
  29   char  fname[NAMELEN] ;
  30   char * fn = "allocs.inc" ;
  31   char * fnCalls = "allocs_calls.inc" ;
  32   node_t *p;
  33
  34   // Open array of allocs_[n].F
  35   int    numFiles = 32;
  36   int    idx      = 0;
  37   int    start    = 0;
  38   int    stop     = -1;
  39   int    primaryFields = 0;
  40   FILE * fpSub;
  41   char * filename_prefix = "allocs_" ;
  42
  43   if ( dirname == NULL ) return(1) ;
  44   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
  45   else                       { sprintf(fname,"%s",fn) ; }
  46   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
  47
  48   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fnCalls) ; }
  49   else                       { sprintf(fname,"%s",fnCalls) ; }
  50   if ((fpCalls = fopen( fname , "w" )) == NULL ) return(1) ;
  51
  52   for ( p = Domain.fields; p != NULL ; p = p->next ) { primaryFields++ ; }
  53
  54   print_warning(fp,fname) ;
  55   fprintf(
  56           fp,
  57           "INTERFACE\n"
  58           );
  59   for ( idx = 0; idx < numFiles; idx++ )
  60   {
  61     if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%d.F",dirname,filename_prefix,idx) ; }
  62     else                       { sprintf(fname,"%s%d.F",dirname,filename_prefix,idx ) ; }
  63     if ((fpSub = fopen( fname , "w" )) == NULL ) return(1) ;
  64
  65     print_warning(fpSub,fname) ;
  66     fprintf(
  67             fp,
  68             "  SUBROUTINE %s%d( grid,   id, setinitval_in ,  tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated ,  &\n"
  69             "           sd31, ed31, sd32, ed32, sd33, ed33, &\n"
  70             "           sm31 , em31 , sm32 , em32 , sm33 , em33 , &\n"
  71             "           sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &\n"
  72             "           sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &\n"
  73             "           sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &\n"
  74             "           sm31x, em31x, sm32x, em32x, sm33x, em33x, &\n"
  75             "           sm31y, em31y, sm32y, em32y, sm33y, em33y )\n"
  76             "    USE module_domain_type\n"
  77             "    USE module_configure, ONLY : model_config_rec, grid_config_rec_type, in_use_for_config, model_to_grid_config_rec\n"
  78             "    USE module_scalar_tables ! this includes module_state_description too\n"
  79             "    IMPLICIT NONE\n"
  80             "    !  Input data.\n\n"
  81             "    TYPE(domain)               , POINTER          :: grid\n"
  82             "    INTEGER , INTENT(IN)            :: id\n"
  83             "    INTEGER , INTENT(IN)            :: setinitval_in   ! 3 = everything, 1 = arrays only, 0 = none\n"
  84             "    INTEGER , INTENT(IN)            :: sd31, ed31, sd32, ed32, sd33, ed33\n"
  85             "    INTEGER , INTENT(IN)            :: sm31, em31, sm32, em32, sm33, em33\n"
  86             "    INTEGER , INTENT(IN)            :: sp31, ep31, sp32, ep32, sp33, ep33\n"
  87             "    INTEGER , INTENT(IN)            :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x\n"
  88             "    INTEGER , INTENT(IN)            :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y\n"
  89             "    INTEGER , INTENT(IN)            :: sm31x, em31x, sm32x, em32x, sm33x, em33x\n"
  90             "    INTEGER , INTENT(IN)            :: sm31y, em31y, sm32y, em32y, sm33y, em33y\n\n"
  91             "    ! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.\n"
  92             "    ! e.g. to set both 1st and second time level, use 3\n"
  93             "    !      to set only 1st                        use 1\n"
  94             "    !      to set only 2st                        use 2\n"
  95             "    INTEGER , INTENT(IN)            :: tl_in\n\n"
  96             "    ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated\n"
  97             "    ! false otherwise (all allocated, modulo tl above)\n"
  98             "    LOGICAL , INTENT(IN)            :: inter_domain_in, okay_to_alloc_in\n\n"
  99             "    INTEGER(KIND=8) , INTENT(INOUT)         :: num_bytes_allocated\n"
 100             "  END SUBROUTINE %s%d\n",
 101             filename_prefix, idx, filename_prefix, idx
 102             );
 103
 104     // Call the functions in the calls inc
 105     fprintf(
 106             fpCalls,
 107             "CALL %s%d( grid,   id, setinitval_in ,  tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated ,  &\n"
 108             "           sd31, ed31, sd32, ed32, sd33, ed33, &\n"
 109             "           sm31 , em31 , sm32 , em32 , sm33 , em33 , &\n"
 110             "           sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &\n"
 111             "           sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &\n"
 112             "           sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &\n"
 113             "           sm31x, em31x, sm32x, em32x, sm33x, em33x, &\n"
 114             "           sm31y, em31y, sm32y, em32y, sm33y, em33y )\n",
 115             filename_prefix, idx
 116             );
 117
 118     fprintf(
 119             fpSub,
 120             "SUBROUTINE %s%d( grid,   id, setinitval_in ,  tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated ,  &\n"
 121             "         sd31, ed31, sd32, ed32, sd33, ed33, &\n"
 122             "         sm31 , em31 , sm32 , em32 , sm33 , em33 , &\n"
 123             "         sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &\n"
 124             "         sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &\n"
 125             "         sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &\n"
 126             "         sm31x, em31x, sm32x, em32x, sm33x, em33x, &\n"
 127             "         sm31y, em31y, sm32y, em32y, sm33y, em33y )\n"
 128             "  USE module_domain_type\n"
 129             "  USE module_configure, ONLY : model_config_rec, grid_config_rec_type, in_use_for_config, model_to_grid_config_rec\n"
 130             "  USE module_scalar_tables ! this includes module_state_description too\n"
 131             "  IMPLICIT NONE\n"
 132             "  !  Input data.\n\n"
 133             "  TYPE(domain)               , POINTER          :: grid\n"
 134             "  INTEGER , INTENT(IN)            :: id\n"
 135             "  INTEGER , INTENT(IN)            :: setinitval_in   ! 3 = everything, 1 = arrays only, 0 = none\n"
 136             "  INTEGER , INTENT(IN)            :: sd31, ed31, sd32, ed32, sd33, ed33\n"
 137             "  INTEGER , INTENT(IN)            :: sm31, em31, sm32, em32, sm33, em33\n"
 138             "  INTEGER , INTENT(IN)            :: sp31, ep31, sp32, ep32, sp33, ep33\n"
 139             "  INTEGER , INTENT(IN)            :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x\n"
 140             "  INTEGER , INTENT(IN)            :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y\n"
 141             "  INTEGER , INTENT(IN)            :: sm31x, em31x, sm32x, em32x, sm33x, em33x\n"
 142             "  INTEGER , INTENT(IN)            :: sm31y, em31y, sm32y, em32y, sm33y, em33y\n\n"
 143             "  ! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.\n"
 144             "  ! e.g. to set both 1st and second time level, use 3\n"
 145             "  !      to set only 1st                        use 1\n"
 146             "  !      to set only 2st                        use 2\n"
 147             "  INTEGER , INTENT(IN)            :: tl_in\n\n"
 148             "  ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated\n"
 149             "  ! false otherwise (all allocated, modulo tl above)\n"
 150             "  LOGICAL , INTENT(IN)            :: inter_domain_in, okay_to_alloc_in\n\n"
 151             "  INTEGER(KIND=8) , INTENT(INOUT)         :: num_bytes_allocated\n"
 152             "  !  Local data.\n"
 153             "  INTEGER idum1, idum2, spec_bdy_width\n"
 154             "  REAL    initial_data_value\n"
 155             "  CHARACTER (LEN=256) message\n"
 156             "  INTEGER tl\n"
 157             "  LOGICAL inter_domain, okay_to_alloc\n"
 158             "  INTEGER setinitval\n"
 159             "  INTEGER sr_x, sr_y\n\n"
 160             "  !declare ierr variable for error checking ALLOCATE calls\n"
 161             "  INTEGER ierr\n\n"
 162             "  INTEGER                              :: loop\n"
 163             "  INTEGER(KIND=8)                      :: nba ! number of bytes allocated per variable\n"
 164             "  CHARACTER(LEN=256)                   :: message_string\n\n"
 165             "  ! Local data\n\n"
 166             "  TYPE ( grid_config_rec_type ) :: config_flags\n\n"
 167             "  INTEGER                         :: k_start , k_end, its, ite, jts, jte\n"
 168             "  INTEGER                         :: ids , ide , jds , jde , kds , kde , &\n"
 169             "                                    ims , ime , jms , jme , kms , kme , &\n"
 170             "                                    ips , ipe , jps , jpe , kps , kpe\n\n"
 171             "  INTEGER                         :: sids , side , sjds , sjde , skds , skde , &\n"
 172             "                                    sims , sime , sjms , sjme , skms , skme , &\n"
 173             "                                    sips , sipe , sjps , sjpe , skps , skpe\n\n"
 174             "  INTEGER ::              imsx, imex, jmsx, jmex, kmsx, kmex,    &\n"
 175             "                          ipsx, ipex, jpsx, jpex, kpsx, kpex,    &\n"
 176             "                          imsy, imey, jmsy, jmey, kmsy, kmey,    &\n"
 177             "                          ipsy, ipey, jpsy, jpey, kpsy, kpey\n\n"
 178             "  data_ordering : SELECT CASE ( model_data_order )\n"
 179             "    CASE  ( DATA_ORDER_XYZ )\n"
 180             "        ids = sd31 ; ide = ed31 ; jds = sd32 ; jde = ed32 ; kds = sd33 ; kde = ed33 ;\n"
 181             "        ims = sm31 ; ime = em31 ; jms = sm32 ; jme = em32 ; kms = sm33 ; kme = em33 ;\n"
 182             "        ips = sp31 ; ipe = ep31 ; jps = sp32 ; jpe = ep32 ; kps = sp33 ; kpe = ep33 ;\n"
 183             "        imsx = sm31x ; imex = em31x ; jmsx = sm32x ; jmex = em32x ; kmsx = sm33x ; kmex = em33x ;\n"
 184             "        ipsx = sp31x ; ipex = ep31x ; jpsx = sp32x ; jpex = ep32x ; kpsx = sp33x ; kpex = ep33x ;\n"
 185             "        imsy = sm31y ; imey = em31y ; jmsy = sm32y ; jmey = em32y ; kmsy = sm33y ; kmey = em33y ;\n"
 186             "        ipsy = sp31y ; ipey = ep31y ; jpsy = sp32y ; jpey = ep32y ; kpsy = sp33y ; kpey = ep33y ;\n"
 187             "    CASE  ( DATA_ORDER_YXZ )\n"
 188             "        ids = sd32  ; ide = ed32  ; jds = sd31  ; jde = ed31  ; kds = sd33  ; kde = ed33  ;\n"
 189             "        ims = sm32  ; ime = em32  ; jms = sm31  ; jme = em31  ; kms = sm33  ; kme = em33  ;\n"
 190             "        ips = sp32  ; ipe = ep32  ; jps = sp31  ; jpe = ep31  ; kps = sp33  ; kpe = ep33  ;\n"
 191             "        imsx = sm32x  ; imex = em32x  ; jmsx = sm31x  ; jmex = em31x  ; kmsx = sm33x  ; kmex = em33x  ;\n"
 192             "        ipsx = sp32x  ; ipex = ep32x  ; jpsx = sp31x  ; jpex = ep31x  ; kpsx = sp33x  ; kpex = ep33x  ;\n"
 193             "        imsy = sm32y  ; imey = em32y  ; jmsy = sm31y  ; jmey = em31y  ; kmsy = sm33y  ; kmey = em33y  ;\n"
 194             "        ipsy = sp32y  ; ipey = ep32y  ; jpsy = sp31y  ; jpey = ep31y  ; kpsy = sp33y  ; kpey = ep33y  ;\n"
 195             "    CASE  ( DATA_ORDER_ZXY )\n"
 196             "        ids = sd32  ; ide = ed32  ; jds = sd33  ; jde = ed33  ; kds = sd31  ; kde = ed31  ;\n"
 197             "        ims = sm32  ; ime = em32  ; jms = sm33  ; jme = em33  ; kms = sm31  ; kme = em31  ;\n"
 198             "        ips = sp32  ; ipe = ep32  ; jps = sp33  ; jpe = ep33  ; kps = sp31  ; kpe = ep31  ;\n"
 199             "        imsx = sm32x  ; imex = em32x  ; jmsx = sm33x  ; jmex = em33x  ; kmsx = sm31x  ; kmex = em31x  ;\n"
 200             "        ipsx = sp32x  ; ipex = ep32x  ; jpsx = sp33x  ; jpex = ep33x  ; kpsx = sp31x  ; kpex = ep31x  ;\n"
 201             "        imsy = sm32y  ; imey = em32y  ; jmsy = sm33y  ; jmey = em33y  ; kmsy = sm31y  ; kmey = em31y  ;\n"
 202             "        ipsy = sp32y  ; ipey = ep32y  ; jpsy = sp33y  ; jpey = ep33y  ; kpsy = sp31y  ; kpey = ep31y  ;\n"
 203             "    CASE  ( DATA_ORDER_ZYX )\n"
 204             "        ids = sd33  ; ide = ed33  ; jds = sd32  ; jde = ed32  ; kds = sd31  ; kde = ed31  ;\n"
 205             "        ims = sm33  ; ime = em33  ; jms = sm32  ; jme = em32  ; kms = sm31  ; kme = em31  ;\n"
 206             "        ips = sp33  ; ipe = ep33  ; jps = sp32  ; jpe = ep32  ; kps = sp31  ; kpe = ep31  ;\n"
 207             "        imsx = sm33x  ; imex = em33x  ; jmsx = sm32x  ; jmex = em32x  ; kmsx = sm31x  ; kmex = em31x  ;\n"
 208             "        ipsx = sp33x  ; ipex = ep33x  ; jpsx = sp32x  ; jpex = ep32x  ; kpsx = sp31x  ; kpex = ep31x  ;\n"
 209             "        imsy = sm33y  ; imey = em33y  ; jmsy = sm32y  ; jmey = em32y  ; kmsy = sm31y  ; kmey = em31y  ;\n"
 210             "        ipsy = sp33y  ; ipey = ep33y  ; jpsy = sp32y  ; jpey = ep32y  ; kpsy = sp31y  ; kpey = ep31y  ;\n"
 211             "    CASE  ( DATA_ORDER_XZY )\n"
 212             "        ids = sd31  ; ide = ed31  ; jds = sd33  ; jde = ed33  ; kds = sd32  ; kde = ed32  ;\n"
 213             "        ims = sm31  ; ime = em31  ; jms = sm33  ; jme = em33  ; kms = sm32  ; kme = em32  ;\n"
 214             "        ips = sp31  ; ipe = ep31  ; jps = sp33  ; jpe = ep33  ; kps = sp32  ; kpe = ep32  ;\n"
 215             "        imsx = sm31x  ; imex = em31x  ; jmsx = sm33x  ; jmex = em33x  ; kmsx = sm32x  ; kmex = em32x  ;\n"
 216             "        ipsx = sp31x  ; ipex = ep31x  ; jpsx = sp33x  ; jpex = ep33x  ; kpsx = sp32x  ; kpex = ep32x  ;\n"
 217             "        imsy = sm31y  ; imey = em31y  ; jmsy = sm33y  ; jmey = em33y  ; kmsy = sm32y  ; kmey = em32y  ;\n"
 218             "        ipsy = sp31y  ; ipey = ep31y  ; jpsy = sp33y  ; jpey = ep33y  ; kpsy = sp32y  ; kpey = ep32y  ;\n"
 219             "    CASE  ( DATA_ORDER_YZX )\n"
 220             "        ids = sd33  ; ide = ed33  ; jds = sd31  ; jde = ed31  ; kds = sd32  ; kde = ed32  ;\n"
 221             "        ims = sm33  ; ime = em33  ; jms = sm31  ; jme = em31  ; kms = sm32  ; kme = em32  ;\n"
 222             "        ips = sp33  ; ipe = ep33  ; jps = sp31  ; jpe = ep31  ; kps = sp32  ; kpe = ep32  ;\n"
 223             "        imsx = sm33x  ; imex = em33x  ; jmsx = sm31x  ; jmex = em31x  ; kmsx = sm32x  ; kmex = em32x  ;\n"
 224             "        ipsx = sp33x  ; ipex = ep33x  ; jpsx = sp31x  ; jpex = ep31x  ; kpsx = sp32x  ; kpex = ep32x  ;\n"
 225             "        imsy = sm33y  ; imey = em33y  ; jmsy = sm31y  ; jmey = em31y  ; kmsy = sm32y  ; kmey = em32y  ;\n"
 226             "        ipsy = sp33y  ; ipey = ep33y  ; jpsy = sp31y  ; jpey = ep31y  ; kpsy = sp32y  ; kpey = ep32y  ;\n"
 227             "  END SELECT data_ordering\n\n"
 228             "  CALL model_to_grid_config_rec ( id , model_config_rec , config_flags )\n\n"
 229             "  CALL nl_get_sr_x( id , sr_x )\n"
 230             "  CALL nl_get_sr_y( id , sr_y )\n\n"
 231             "  tl = tl_in\n"
 232             "  inter_domain = inter_domain_in\n"
 233             "  okay_to_alloc = okay_to_alloc_in\n\n"
 234             "#if ( RWORDSIZE == 8 )\n"
 235             "  initial_data_value = 0.\n"
 236             "#else\n"
 237             "  CALL get_initial_data_value ( initial_data_value )\n"
 238             "#endif\n\n"
 239             "#ifdef NO_INITIAL_DATA_VALUE\n"
 240             "  setinitval = 0\n"
 241             "#else\n"
 242             "  setinitval = setinitval_in\n"
 243             "#endif\n\n"
 244             "  CALL nl_get_spec_bdy_width( 1, spec_bdy_width )\n\n",
 245             filename_prefix, idx
 246             );
 247
 248     // Determine start/stop fields
 249     start = stop + 1;
 250     if ( idx == numFiles - 1 )
 251     {
 252       // This should catch divisions that don't perfectly fit numFiles with at most numFiles
 253       // extra fields in the last file
 254       stop = primaryFields;
 255     }
 256     else
 257     {
 258       stop  = start + ( primaryFields / numFiles );
 259     }
 260     gen_alloc2( fpSub , "grid%", NULL, &Domain, start, stop, 1 ) ;
 261     fprintf(
 262             fpSub,
 263             "END SUBROUTINE %s%d\n",
 264             filename_prefix, idx
 265             );
 266   }
 267   fprintf(
 268           fp,
 269           "END INTERFACE\n"
 270           );
 271
 272   close_the_file( fpCalls ) ;
 273   close_the_file( fp ) ;
 274   return(0) ;
 275 }
 276
 277 int
 278 get_count_for_alloc( node_t *node , int *numguys, int * stats )
 279 {
 280   node_t * p ;
 281   for ( p = node->fields ; p != NULL ; p = p->next ) {
 282     if        ( p->type != NULL && p->type->type_type == DERIVED ) {
 283       get_count_for_alloc( p->type , numguys, stats ) ;
 284     } else if (p->ndims >= 0) {
 285        (*numguys)++ ;
 286        if        ( p->ndims == 0 ) {
 287          stats[p->ndims]++ ;
 288        } else if ( p->ndims == 1 ) {
 289          stats[p->ndims]++ ;
 290        } else if ( p->ndims == 2 ) {
 291          stats[p->ndims]++ ;
 292        } else if ( p->ndims == 3 ) {
 293          stats[p->ndims]++ ;
 294        }
 295     }
 296   }
 297   return 0; /* SamT: bug fix: return a value */
 298 }
 299
 300 int
 301 nolistthese( char * ) ;
 302
 303 int
 304 gen_alloc2 ( FILE * fp , char * structname , char * structname2 , node_t * node, int start, int stop, int sw ) /* 1 = allocate, 2 = just count */
 305 {
 306   node_t * p ;
 307   int tag ;
 308   char post[NAMELEN], post_for_count[NAMELEN] ;
 309   char fname[NAMELEN], dname[NAMELEN], dname_tmp[NAMELEN] ;
 310   char x[NAMELEN] ;
 311   char x2[NAMELEN], fname2[NAMELEN] ;
 312   char dimname[3][NAMELEN] ;
 313   char tchar ;
 314   unsigned int *io_mask ;
 315   int nd ;
 316   int restart ;
 317   int currentIdx = -1;
 318
 319   if ( node == NULL ) return(1) ;
 320
 321   for ( p = node->fields ; p != NULL ; p = p->next )
 322   {
 323     // Skip if this field is not part of [start,stop] and stop != -1, so -1 can be used to force output
 324     currentIdx++;;
 325     if ( currentIdx < start && stop != -1 )
 326     {
 327       continue;
 328     }
 329     // We should be at [start] or forcing output via stop == -1
 330     if ( currentIdx > stop && stop != -1 )
 331     {
 332       // We passed stop and are not forcing, exit loop
 333       break;
 334     }
 335
 336     nd = p->ndims + ((p->node_kind & FOURD)?1:0) ;
 337
 338     /* construct data name -- maybe same as vname if dname not spec'd  */
 339     if ( strlen(p->dname) == 0 || !strcmp(p->dname,"-") || p->dname[0] == ' ' )
 340                                                           { strcpy(dname_tmp,p->name) ; }
 341     else                                                  { strcpy(dname_tmp,p->dname) ; }
 342     make_upper_case(dname_tmp) ;
 343
 344 /*
 345    Generate error if input or output for two state variables would be generated with the same dataname
 346
 347    example wrong:
 348      misc    tg      "SOILTB"   -> gen_tg,SOILTB
 349      misc    soiltb  "SOILTB"   -> gen_soiltb,SOILTB
 350
 351 */
 352 if ( tag == 1 )
 353 {
 354      char dname_symbol[128] ;
 355      sym_nodeptr sym_node ;
 356
 357      sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ;
 358      /* check and see if it is in the symbol table already */
 359
 360      if ((sym_node = sym_get( dname_symbol )) == NULL ) {
 361         /* add it */
 362       sym_node = sym_add ( dname_symbol ) ;
 363       strcpy( sym_node->internal_name , p->name ) ;
 364     } else {
 365       fprintf(stderr,"REGISTRY ERROR: Data-name collision on %s for %s -- %s\n",
 366       dname_tmp,p->name,p->dname ) ;
 367     }
 368 }
 369 /* end July 2004 */
 370
 371
 372     if ( p->ndims == 0 ) {
 373       if ( p->type->name[0] != 'c' && p->type->type_type != DERIVED && p->node_kind != RCONFIG && !nolistthese(p->name) ) {
 374         for ( tag = 1 ; tag <= p->ntl ; tag++ )
 375         {
 376           strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
 377           if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ;
 378           else              strcpy(dname,dname_tmp) ;
 379
 380           fprintf(fp,"  IF (.NOT.grid%%is_intermediate) THEN\n") ;
 381           fprintf(fp,"   ALLOCATE( grid%%tail_statevars%%next )\n") ;
 382           fprintf(fp,"   grid%%tail_statevars => grid%%tail_statevars%%next\n") ;
 383           fprintf(fp,"   NULLIFY( grid%%tail_statevars%%next )\n" ) ;
 384           fprintf(fp,"   grid%%tail_statevars%%ProcOrient    = '  '\n") ;
 385           fprintf(fp,"   grid%%tail_statevars%%VarName = '%s'\n",fname ) ;
 386           fprintf(fp,"   grid%%tail_statevars%%DataName = '%s'\n",dname ) ;
 387           fprintf(fp,"   grid%%tail_statevars%%Description = '%s'\n",p->descrip ) ;
 388           fprintf(fp,"   grid%%tail_statevars%%Units = '%s'\n",p->units ) ;
 389           fprintf(fp,"   grid%%tail_statevars%%Type    = '%c'\n",p->type->name[0]) ;
 390           fprintf(fp,"   grid%%tail_statevars%%Ntl = %d\n",p->ntl<2?0:tag+p->ntl*100 ) ; /* if single tl, then 0, else tl itself */
 391           fprintf(fp,"   grid%%tail_statevars%%Restart  = %s\n", (p->restart)?".TRUE.":".FALSE." ) ;
 392           fprintf(fp,"   grid%%tail_statevars%%Ndim    = %d\n",p->ndims ) ;
 393           fprintf(fp,"   grid%%tail_statevars%%scalar_array  = .FALSE. \n" ) ;
 394           fprintf(fp,"   grid%%tail_statevars%%%cfield_%1dd => %s%s\n",p->type->name[0],p->ndims, structname, fname ) ;
 395           io_mask = p->io_mask ;
 396           if ( io_mask != NULL ) {
 397             int i ;
 398             for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) {
 399               fprintf(fp,"  grid%%tail_statevars%%streams(%d) = %d ! %08x \n", i+1, io_mask[i], io_mask[i] ) ;
 400             }
 401           }
 402           fprintf(fp,"  ENDIF\n") ;
 403         }
 404       }
 405       if ( sw == 1 ) {
 406         for ( tag = 1 ; tag <= p->ntl ; tag++ )
 407         {
 408           strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
 409           if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ;
 410           else              strcpy(dname,dname_tmp) ;
 411           if( !strcmp( p->type->name , "real" ) ||
 412               !strcmp( p->type->name , "doubleprecision" )  ) { /* if a real */
 413             fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=initial_data_value\n",
 414                         structname ,
 415                         fname ) ;
 416           } else if ( !strcmp( p->type->name , "integer" ) ) {
 417             fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=0\n",
 418                         structname ,
 419                         fname ) ;
 420           } else if ( !strcmp( p->type->name , "logical" ) ) {
 421             fprintf(fp, "IF ( setinitval .EQ. 3 ) %s%s=.FALSE.\n",
 422                         structname ,
 423                         fname ) ;
 424           }
 425         }
 426       }
 427     }
 428     if ( (p->ndims > 0 || p->boundary_array) && (  /* any array or a boundary array and...   */
 429           (p->node_kind & FIELD) ||                /* scalar arrays                          */
 430           (p->node_kind & FOURD) )                 /* scalar arrays                          */
 431                          )
 432     {
 433       if ( p->type != NULL ) {
 434         tchar = '?' ;
 435         if      ( !strcmp( p->type->name , "real" ) )            { tchar = 'R' ; }
 436         else if ( !strcmp( p->type->name , "doubleprecision" ) ) { tchar = 'D' ; }
 437         else if ( !strcmp( p->type->name , "logical" ) )         { tchar = 'L' ; }
 438         else if ( !strcmp( p->type->name , "integer" ) )         { tchar = 'I' ; }
 439         else { fprintf(stderr,"WARNING: what is the type for %s ?\n", p->name) ; }
 440       }
 441       if ( p->node_kind & FOURD ) { sprintf(post,           ",num_%s)",field_name(t4,p,0)) ;
 442                                     sprintf(post_for_count, "*num_%s)",field_name(t4,p,0)) ; }
 443       else                        { sprintf(post,           ")" ) ;
 444                                     sprintf(post_for_count, ")" ) ;   }
 445       for ( tag = 1 ; tag <= p->ntl ; tag++ )
 446       {
 447         if ( !strcmp ( p->use , "_4d_bdy_array_") ) {
 448           strcpy(fname,p->name) ;
 449         } else {
 450           strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
 451         }
 452         if ( structname2 != NULL ) {
 453           sprintf(fname2,"%s%s",structname2,fname) ;
 454         } else {
 455           strcpy(fname2,fname) ;
 456         }
 457
 458 /* check for errors in memory allocation */
 459
 460        if ( ! p->boundary_array ) { fprintf(fp,"IF(okay_to_alloc.AND.in_use_for_config(id,'%s')",fname2) ; }
 461        else                       { fprintf(fp,"IF(.TRUE.") ; }
 462
 463        if ( ! ( p->node_kind & FOURD ) && sw == 1 &&
 464             ! ( p->nest_mask & INTERP_DOWN || p->nest_mask & FORCE_DOWN || p->nest_mask & INTERP_UP || p->nest_mask & SMOOTH_UP ) )
 465        {
 466          fprintf(fp,".AND.(.NOT.grid%%is_intermediate)") ;
 467        }
 468        if ( p->ntl > 1 && sw == 1 ) {
 469          fprintf(fp,".AND.(IAND(%d,tl).NE.0)",tag) ;
 470        }
 471        fprintf(fp,")THEN\n") ;
 472        if ( p->boundary_array && sw_new_bdys ) {
 473          int bdy ;
 474          for ( bdy = 1 ; bdy <= 4 ; bdy++ )
 475          {
 476            if( p->type != NULL && tchar != '?' ) {
 477              fprintf(fp,"  num_bytes_allocated = num_bytes_allocated + &\n(%s) * %cWORDSIZE\n",
 478                          array_size_expression("", "(", bdy, t2, p, post_for_count, "model_config_rec%"),
 479                          tchar) ;
 480            }
 481            if ( sw == 1 ) {
 482              fprintf(fp, "  ALLOCATE(%s%s%s%s,STAT=ierr)\n  if (ierr.ne.0) then\n    CALL wrf_error_fatal ( &\n    'frame/module_domain.f: Failed to allocate %s%s%s%s. ')\n  endif\n",
 483                 structname, fname, bdy_indicator(bdy),
 484                 dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"),
 485                 structname, fname, bdy_indicator(bdy),
 486                 dimension_with_ranges( "", "(", bdy, t2, p, post, "model_config_rec%"));
 487              fprintf(fp, "  IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s%s=", structname , fname , bdy_indicator(bdy));
 488              if( p->type != NULL  &&   (!strcmp( p->type->name , "real" )
 489                                    || !strcmp( p->type->name , "doubleprecision") ) )   {
 490              /* if a real */
 491                fprintf(fp, "initial_data_value\n");
 492              } else if ( !strcmp( p->type->name , "logical" ) ) {
 493                fprintf(fp, ".FALSE.\n");
 494              } else if ( !strcmp( p->type->name , "integer" ) ) {
 495                fprintf(fp, "0\n");
 496              }
 497            }
 498          }
 499        } else {
 500          if( p->type != NULL && tchar != '?' ) {
 501            fprintf(fp,"  num_bytes_allocated = num_bytes_allocated + &\n(%s) * %cWORDSIZE\n",
 502                    array_size_expression("", "(", -1, t2, p, post_for_count, "model_config_rec%"),
 503                    tchar) ;
 504            fprintf(fp,"  nba = &\n(%s) * %cWORDSIZE\n",
 505                    array_size_expression("", "(", -1, t2, p, post_for_count, "model_config_rec%"),
 506                    tchar) ;
 507            fprintf(fp,"#if ( SHOW_ALL_VARS_USED == 1 )\n") ;
 508            fprintf(fp,"  WRITE(message_string,fmt='(a,i12)') '%s: bytes = ',nba\n", fname) ;
 509            fprintf(fp,"  CALL wrf_message(message_string)\n") ;
 510            fprintf(fp,"#endif\n") ;
 511          }
 512          if ( sw == 1 ) {
 513            fprintf(fp, "  ALLOCATE(%s%s%s,STAT=ierr)\n  if (ierr.ne.0) then\n    CALL wrf_error_fatal ( &\n    'frame/module_domain.f: Failed to allocate %s%s%s. ')\n  endif\n",
 514                 structname, fname,
 515                 dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"),
 516                 structname, fname,
 517                 dimension_with_ranges( "", "(", -1, t2, p, post, "model_config_rec%"));
 518            fprintf(fp, "  IF ( setinitval .EQ. 1 .OR. setinitval .EQ. 3 ) %s%s=", structname , fname);
 519
 520            if( p->type != NULL  &&   (!strcmp( p->type->name , "real" )
 521                                    || !strcmp( p->type->name , "doubleprecision") ) )   {
 522            /* if a real */
 523              fprintf(fp, "initial_data_value\n");
 524            } else if ( !strcmp( p->type->name , "logical" ) ) {
 525              fprintf(fp, ".FALSE.\n");
 526            } else if ( !strcmp( p->type->name , "integer" ) ) {
 527              fprintf(fp, "0\n");
 528            }
 529
 530            if ( p->type->name[0] == 'l' && p->ndims >= 3 ) {
 531              fprintf(stderr,"ADVISORY: %1dd logical array %s is allowed but cannot be input or output\n",
 532                              p->ndims, p->name ) ;
 533
 534            }
 535
 536            if ( p->type->type_type != DERIVED && p->node_kind != RCONFIG && !nolistthese(p->name) &&
 537                 ! ( p->type->name[0] == 'l' && p->ndims >= 3 ) )  /* dont list logical arrays larger than 2d  */
 538            {
 539              char memord[NAMELEN], stagstr[NAMELEN] ;
 540              char *ornt ;
 541
 542              if      ( p->proc_orient == ALL_X_ON_PROC ) ornt = "X" ;
 543              else if ( p->proc_orient == ALL_Y_ON_PROC ) ornt = "Y" ;
 544              else                                        ornt = " " ;
 545
 546              strcpy(stagstr, "") ;
 547              if ( p->node_kind & FOURD ) {
 548                set_mem_order( p->members, memord , NAMELEN) ;
 549                if ( p->members->stag_x ) strcat(stagstr, "X") ;
 550                if ( p->members->stag_y ) strcat(stagstr, "Y") ;
 551                if ( p->members->stag_z ) strcat(stagstr, "Z") ;
 552              } else {
 553                set_mem_order( p, memord , NAMELEN) ;
 554                if ( p->stag_x ) strcat(stagstr, "X") ;
 555                if ( p->stag_y ) strcat(stagstr, "Y") ;
 556                if ( p->stag_z ) strcat(stagstr, "Z") ;
 557              }
 558              memord[3] = '\0' ; /* snip off any extra dimensions */
 559
 560              if ( p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,tag) ;
 561              else                                    strcpy(dname,dname_tmp) ;
 562
 563              fprintf(fp,"  IF (.NOT.grid%%is_intermediate) THEN\n") ; /*{*/
 564              fprintf(fp,"  ALLOCATE( grid%%tail_statevars%%next )\n" ) ;
 565              fprintf(fp,"  grid%%tail_statevars => grid%%tail_statevars%%next\n") ;
 566              fprintf(fp,"  NULLIFY( grid%%tail_statevars%%next )\n") ;
 567              fprintf(fp,"  grid%%tail_statevars%%VarName = '%s'\n", fname) ;
 568              fprintf(fp,"  grid%%tail_statevars%%DataName = '%s'\n", dname) ;
 569              fprintf(fp,"  grid%%tail_statevars%%Description = '%s'\n",p->descrip ) ;
 570              fprintf(fp,"  grid%%tail_statevars%%Units = '%s'\n",p->units ) ;
 571              fprintf(fp,"  grid%%tail_statevars%%Type    = '%c'\n", p->type->name[0]) ;
 572              fprintf(fp,"  grid%%tail_statevars%%ProcOrient    = '%s'\n", ornt) ;
 573              fprintf(fp,"  grid%%tail_statevars%%MemoryOrder  = '%s'\n", memord) ;
 574              fprintf(fp,"  grid%%tail_statevars%%Stagger      = '%s'\n", stagstr) ;
 575                            /* in next line for Ntl, if single tl, then zero, otherwise tl itself */
 576              fprintf(fp,"  grid%%tail_statevars%%Ntl     = %d\n", p->ntl<2?0:tag+p->ntl*100 ) ;
 577              fprintf(fp,"  grid%%tail_statevars%%Ndim    = %d\n", nd ) ;
 578              restart = 0 ;
 579              if ( p->node_kind & FOURD ) {
 580                node_t *q ;
 581                for ( q = p->members ; q->next != NULL ; q = q->next ) {  /* use the last one */
 582                  if ( q != NULL ) {
 583                    restart = q->restart ;
 584                  }
 585                }
 586              } else {
 587                restart = p->restart ;
 588              }
 589              fprintf(fp,"  grid%%tail_statevars%%Restart  = %s\n", (restart)?".TRUE.":".FALSE." ) ;
 590              fprintf(fp,"  grid%%tail_statevars%%scalar_array = %s\n", (p->node_kind & FOURD)?".TRUE.":".FALSE.") ;
 591              fprintf(fp,"  grid%%tail_statevars%%%cfield_%1dd => %s%s\n", p->type->name[0],nd, structname, fname ) ;
 592              if ( p->node_kind & FOURD ) {
 593                fprintf(fp,"  grid%%tail_statevars%%num_table => %s_num_table\n",   p->name ) ;
 594                fprintf(fp,"  grid%%tail_statevars%%index_table => %s_index_table\n",   p->name ) ;
 595                fprintf(fp,"  grid%%tail_statevars%%boundary_table => %s_boundary_table\n",   p->name ) ;
 596                fprintf(fp,"  grid%%tail_statevars%%dname_table => %s_dname_table\n",   p->name ) ;
 597                fprintf(fp,"  grid%%tail_statevars%%desc_table => %s_desc_table\n",   p->name ) ;
 598                fprintf(fp,"  grid%%tail_statevars%%units_table => %s_units_table\n",   p->name ) ;
 599                fprintf(fp,"  grid%%tail_statevars%%streams_table => %s_streams_table\n",   p->name ) ;
 600              }
 601
 602              if ( p->node_kind & FOURD ) {
 603                node_t *q ;
 604                io_mask = NULL ;
 605                for ( q = p->members ; q->next != NULL ; q = q->next ) {  /* use the last one */
 606                  if ( q != NULL ) {
 607                    io_mask = q->io_mask ;
 608                  }
 609                }
 610              } else {
 611                io_mask = p->io_mask ;
 612              }
 613
 614              if ( io_mask != NULL ) {
 615                int i ;
 616                for ( i = 0 ; i < IO_MASK_SIZE ; i++ ) {
 617                  fprintf(fp,"  grid%%tail_statevars%%streams(%d) = %d ! %08x \n",  i+1, io_mask[i], io_mask[i] ) ;
 618                }
 619              }
 620
 621              {
 622                char ddim[3][2][NAMELEN] ;
 623                char mdim[3][2][NAMELEN] ;
 624                char pdim[3][2][NAMELEN] ;
 625
 626                set_dim_strs3( p, ddim, mdim, pdim , "", 0 ) ;           /* dimensions with staggering */
 627
 628                fprintf(fp,"  grid%%tail_statevars%%sd1 = %s\n", ddim[0][0] ) ;
 629                fprintf(fp,"  grid%%tail_statevars%%ed1 = %s\n", ddim[0][1] ) ;
 630                fprintf(fp,"  grid%%tail_statevars%%sd2 = %s\n", ddim[1][0] ) ;
 631                fprintf(fp,"  grid%%tail_statevars%%ed2 = %s\n", ddim[1][1] ) ;
 632                fprintf(fp,"  grid%%tail_statevars%%sd3 = %s\n", ddim[2][0] ) ;
 633                fprintf(fp,"  grid%%tail_statevars%%ed3 = %s\n", ddim[2][1] ) ;
 634                fprintf(fp,"  grid%%tail_statevars%%sm1 = %s\n", mdim[0][0] ) ;
 635                fprintf(fp,"  grid%%tail_statevars%%em1 = %s\n", mdim[0][1] ) ;
 636                fprintf(fp,"  grid%%tail_statevars%%sm2 = %s\n", mdim[1][0] ) ;
 637                fprintf(fp,"  grid%%tail_statevars%%em2 = %s\n", mdim[1][1] ) ;
 638                fprintf(fp,"  grid%%tail_statevars%%sm3 = %s\n", mdim[2][0] ) ;
 639                fprintf(fp,"  grid%%tail_statevars%%em3 = %s\n", mdim[2][1] ) ;
 640                fprintf(fp,"  grid%%tail_statevars%%sp1 = %s\n", pdim[0][0] ) ;
 641                fprintf(fp,"  grid%%tail_statevars%%ep1 = %s\n", pdim[0][1] ) ;
 642                fprintf(fp,"  grid%%tail_statevars%%sp2 = %s\n", pdim[1][0] ) ;
 643                fprintf(fp,"  grid%%tail_statevars%%ep2 = %s\n", pdim[1][1] ) ;
 644                fprintf(fp,"  grid%%tail_statevars%%sp3 = %s\n", pdim[2][0] ) ;
 645                fprintf(fp,"  grid%%tail_statevars%%ep3 = %s\n", pdim[2][1] ) ;
 646
 647              }
 648              {
 649                int i ;
 650                node_t * dimnode ;
 651                for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
 652                for ( i = 0 ; i < 3 ; i++ )
 653                {
 654                  if (( dimnode = p->dims[i]) != NULL )
 655                  {
 656                    switch ( dimnode->coord_axis )
 657                    {
 658                    case (COORD_X) :
 659                      if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) )
 660                       { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
 661                      else if ( p->dims[i]->subgrid )
 662                       { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
 663                      else
 664                       { strcpy( dimname[i], dimnode->dim_data_name) ; }
 665                      fprintf(fp,"  grid%%tail_statevars%%subgrid_x = %s\n",(p->dims[i]->subgrid)?".TRUE.":".FALSE.") ;
 666                      break ;
 667                    case (COORD_Y) :
 668                      if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) )
 669                       { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
 670                      else if ( p->dims[i]->subgrid )
 671                       { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
 672                      else
 673                       { strcpy( dimname[i], dimnode->dim_data_name) ; }
 674                      fprintf(fp,"  grid%%tail_statevars%%subgrid_y = %s\n",(p->dims[i]->subgrid)?".TRUE.":".FALSE.") ;
 675                      break ;
 676                    case (COORD_Z) :
 677                      if ( p->stag_z )
 678                       { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
 679                      else if ( p->dims[i]->subgrid )
 680                       { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
 681                      else
 682                       { strcpy( dimname[i], dimnode->dim_data_name) ; }
 683                      break ;
 684                    }
 685                  }
 686                }
 687                fprintf(fp,"  grid%%tail_statevars%%dimname1 = '%s'\n", dimname[0] ) ;
 688                fprintf(fp,"  grid%%tail_statevars%%dimname2 = '%s'\n", dimname[1] ) ;
 689                fprintf(fp,"  grid%%tail_statevars%%dimname3 = '%s'\n", dimname[2] ) ;
 690              }
 691              fprintf(fp,"  ENDIF\n") ; /*}*/
 692            }
 693          }
 694        }
 695
 696        fprintf(fp,"ELSE\n") ;
 697
 698        if ( p->boundary_array && sw_new_bdys ) {
 699          int bdy ;
 700          for ( bdy = 1 ; bdy <= 4 ; bdy++ )
 701          {
 702            fprintf(fp, "  ALLOCATE(%s%s%s%s,STAT=ierr)\n  if (ierr.ne.0) then\n    CALL wrf_error_fatal ( &\n    'frame/module_domain.f: Failed to allocate %s%s%s%s.  ')\n  endif\n",
 703                 structname, fname,  bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ),
 704                 structname, fname,  bdy_indicator(bdy), dimension_with_ones( "(",t2,p,")" ) ) ;
 705          }
 706        } else {
 707            fprintf(fp, "  ALLOCATE(%s%s%s,STAT=ierr)\n  if (ierr.ne.0) then\n    CALL wrf_error_fatal ( &\n    'frame/module_domain.f: Failed to allocate %s%s%s.  ')\n  endif\n",
 708                 structname, fname, dimension_with_ones( "(",t2,p,")" ),
 709                 structname, fname, dimension_with_ones( "(",t2,p,")" ) ) ;
 710
 711        }
 712
 713        fprintf(fp,"ENDIF\n") ;  /* end of in_use conditional */
 714
 715       }
 716     }
 717     if ( p->type != NULL )
 718     {
 719       if ( p->type->type_type == DERIVED )
 720       {
 721         sprintf(x,"%s%s%%",structname,p->name ) ;
 722         sprintf(x2,"%s%%",p->name ) ;
 723         gen_alloc2(fp,x, x2, p->type, start, -1, sw) ;
 724       }
 725     }
 726   } /* fraction loop */
 727   return(0) ;
 728 }
 729
 730 #if 0
 731 int
 732 gen_alloc_count ( char * dirname )
 733 {
 734   gen_alloc_count1( dirname ) ;
 735   return(0) ;
 736 }
 737
 738 int
 739 gen_alloc_count1 ( char * dirname )
 740 {
 741   FILE * fp ;
 742   char  fname[NAMELEN] ;
 743   char * fn = "alloc_count.inc" ;
 744
 745   if ( dirname == NULL ) return(1) ;
 746   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
 747   else                       { sprintf(fname,"%s",fn) ; }
 748   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
 749   print_warning(fp,fname) ;
 750   gen_alloc2( fp , "grid%", NULL, &Domain, 0 ) ;
 751   close_the_file( fp ) ;
 752   return(0) ;
 753 }
 754 #endif
 755
 756 int
 757 gen_ddt_write ( char * dirname )
 758 {
 759   FILE * fp ;
 760   char  fname[NAMELEN] ;
 761   char * fn = "write_ddt.inc" ;
 762
 763   if ( dirname == NULL ) return(1) ;
 764   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
 765   else                       { sprintf(fname,"%s",fn) ; }
 766   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
 767   print_warning(fp,fname) ;
 768   gen_ddt_write1( fp , "grid%", &Domain ) ;
 769   close_the_file( fp ) ;
 770   return(0) ;
 771 }
 772
 773 int
 774 gen_ddt_write1 ( FILE * fp , char * structname , node_t * node )
 775 {
 776   node_t * p ;
 777   int tag ;
 778   char post[NAMELEN] ;
 779   char fname[NAMELEN] ;
 780   char x[NAMELEN] ;
 781
 782   if ( node == NULL ) return(1) ;
 783
 784   for ( p = node->fields ; p != NULL ; p = p->next )
 785   {
 786     if ( (p->ndims > 1 && ! p->boundary_array) && (  /* any array or a boundary array and...   */
 787           (p->node_kind & FIELD) ||                  /* scalar arrays or...                    */
 788           (p->node_kind & FOURD) )                   /* scalar arrays or...                    */
 789                          )
 790     {
 791       if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
 792       else                        { sprintf(post,")") ; }
 793       for ( tag = 1 ; tag <= p->ntl ; tag++ )
 794       {
 795        strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
 796
 797        if ( p->node_kind & FOURD ) {
 798          fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG,2)\n",fname,structname,fname) ;
 799        } else {
 800          if ( p->ndims == 2 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,JDEBUG)\n",fname,structname,fname) ;
 801          if ( p->ndims == 3 ) fprintf(fp, "write(0,*)'%s',%s%s(IDEBUG,KDEBUG,JDEBUG)\n",fname,structname,fname) ;
 802        }
 803
 804       }
 805     }
 806   }
 807   return(0) ;
 808 }
 809
 810 int
 811 gen_dealloc ( char * dirname )
 812 {
 813   gen_dealloc1( dirname ) ;
 814   return(0) ;
 815 }
 816
 817 int
 818 gen_dealloc1 ( char * dirname )
 819 {
 820   FILE * fp ;
 821   char  fname[NAMELEN] ;
 822   char * fn = "deallocs.inc" ;
 823   // Open array of deallocs_[n].inc
 824   int    numFiles = 12;
 825   int    idx      = 0;
 826   FILE * fpSub;
 827   char * filename_prefix = "deallocs_" ;
 828
 829   if ( dirname == NULL ) return(1) ;
 830   if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
 831   else                       { sprintf(fname,"%s",fn) ; }
 832   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
 833   print_warning(fp,fname) ;
 834
 835   fprintf(
 836           fp,
 837           "INTERFACE\n"
 838           );
 839   if ( dirname == NULL ) return(1) ;
 840   for ( idx = 0; idx < numFiles; idx++ )
 841   {
 842     if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s%d.F",dirname,filename_prefix,idx) ; }
 843     else                       { sprintf(fname,"%s%d.F",dirname,filename_prefix,idx ) ; }
 844     if ((fpSub = fopen( fname , "w" )) == NULL ) return(1) ;
 845
 846     print_warning(fpSub,fname) ;
 847
 848     fprintf(
 849             fp,
 850             "  SUBROUTINE %s%d( grid )\n"
 851             "    USE module_wrf_error\n"
 852             "    USE module_domain_type\n"
 853             "    IMPLICIT NONE\n"
 854             "    TYPE( domain ), POINTER :: grid\n  END SUBROUTINE\n",
 855             filename_prefix, idx
 856             );
 857
 858     fprintf(
 859             fpSub,
 860             "SUBROUTINE %s%d( grid )\n"
 861             "  USE module_wrf_error\n"
 862             "  USE module_domain_type\n"
 863             "  IMPLICIT NONE\n"
 864             "  TYPE( domain ), POINTER :: grid\n  INTEGER :: ierr\n",
 865             filename_prefix, idx
 866             );
 867     gen_dealloc2( fpSub, "grid%", &Domain, idx, numFiles );
 868     fprintf(
 869             fpSub,
 870             "END SUBROUTINE %s%d\n",
 871             filename_prefix, idx
 872             );
 873     close_the_file( fpSub ) ;
 874   }
 875   fprintf(
 876           fp,
 877           "END INTERFACE\n"
 878           );
 879
 880   // Call the functions in the inc
 881   for ( idx = 0; idx < numFiles; idx++ )
 882   {
 883     fprintf(
 884           fp,
 885           "CALL %s%d( grid )\n", filename_prefix, idx
 886           );
 887   }
 888   close_the_file( fp ) ;
 889   return(0) ;
 890 }
 891
 892 int
 893 gen_dealloc2 ( FILE * fp , char * structname , node_t * node, int idx, int numFiles )
 894 {
 895   node_t * p ;
 896   int tag ;
 897   char post[NAMELEN] ;
 898   char fname[NAMELEN] ;
 899   char x[NAMELEN] ;
 900   int currentIdx = -1;
 901
 902   if ( node == NULL ) return(1) ;
 903
 904   for ( p = node->fields ; p != NULL ; p = p->next )
 905   {
 906     // Modulo to divert each field based on index to a file
 907     // Skip if this field is not part of that index and idx != -1, so -1 can be used to force output
 908     currentIdx = ( currentIdx + 1 ) % numFiles;
 909     if ( currentIdx != idx && idx != -1 )
 910     {
 911       continue;
 912     }
 913
 914     if ( (p->ndims > 0 || p->boundary_array) && (  /* any array or a boundary array and...   */
 915           (p->node_kind & FIELD) ||                /* scalar arrays or                       */
 916           (p->node_kind & FOURD) )                 /* scalar arrays or                       */
 917                          )
 918     {
 919       if ( p->node_kind & FOURD ) { sprintf(post,",num_%s)",field_name(t4,p,0)) ; }
 920       else                        { sprintf(post,")") ; }
 921       for ( tag = 1 ; tag <= p->ntl ; tag++ )
 922       {
 923         strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
 924
 925         if ( p->boundary && sw_new_bdys ) {
 926           { int bdy ;
 927             for ( bdy = 1 ; bdy <= 4 ; bdy++ ) {
 928 #ifdef USE_ALLOCATABLES
 929                   fprintf(fp,
 930 "IF ( ALLOCATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ;
 931 #else
 932                   fprintf(fp,
 933 "IF ( ASSOCIATED( %s%s%s ) ) THEN \n", structname, fname, bdy_indicator(bdy) ) ;
 934 #endif
 935                   fprintf(fp,
 936 "  DEALLOCATE(%s%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to deallocate %s%s%s. ')\n endif\n",
 937           structname, fname, bdy_indicator(bdy), structname, fname, bdy_indicator(bdy) ) ;
 938 #ifndef USE_ALLOCATABLES
 939                   fprintf(fp,
 940 "  NULLIFY(%s%s%s)\n",structname, fname, bdy_indicator(bdy) ) ;
 941 #endif
 942                   fprintf(fp,
 943 "ENDIF\n" ) ;
 944             }
 945           }
 946         } else {
 947
 948   if (strcmp(fname,"chem_ic")==0)   continue ;  /* !!! add !!! */
 949
 950 #ifdef USE_ALLOCATABLES
 951         fprintf(fp,
 952 "IF ( ALLOCATED( %s%s ) ) THEN \n", structname, fname ) ;
 953 #else
 954         fprintf(fp,
 955 "IF ( ASSOCIATED( %s%s ) ) THEN \n", structname, fname ) ;
 956 #endif
 957         fprintf(fp,
 958 "  DEALLOCATE(%s%s,STAT=ierr)\n if (ierr.ne.0) then\n CALL wrf_error_fatal ( &\n'frame/module_domain.f: Failed to deallocate %s%s. ')\n endif\n",
 959 structname, fname, structname, fname ) ;
 960 #ifndef USE_ALLOCATABLES
 961         fprintf(fp,
 962 "  NULLIFY(%s%s)\n",structname, fname ) ;
 963 #endif
 964         fprintf(fp,
 965 "ENDIF\n" ) ;
 966         }
 967
 968
 969       }
 970     }
 971     if ( p->type != NULL )
 972     {
 973       if ( p->type->type_type == SIMPLE && p->ndims == 0 &&
 974                (!strcmp(p->type->name,"integer") ||
 975                         !strcmp(p->type->name,"real") ||
 976                         !strcmp(p->type->name,"doubleprecision"))
 977               )
 978       {
 979       }
 980       else if ( p->type->type_type == DERIVED )
 981       {
 982         sprintf(x,"%s%s%%",structname,p->name ) ;
 983         gen_dealloc2(fp,x, p->type, idx, -1) ;
 984       }
 985     }
 986   }
 987   return(0) ;
 988 }
 989
 990 int
 991 nolistthese( char * name )
 992 {
 993    return(
 994              !strncmp(name,"auxhist",7)
 995           || !strncmp(name,"auxinput",8)
 996           || !strncmp(name,"oid",3)
 997          ) ;
 998 }