frame/module_domain.F

   1 !WRF:DRIVER_LAYER:DOMAIN_OBJECT
   2 !
   3 !  Following are the routines contained within this MODULE:
   4
   5 !  alloc_and_configure_domain        1. Allocate the space for a single domain (constants
   6 !                                       and null terminate pointers).
   7 !                                    2. Connect the domains as a linked list.
   8 !                                    3. Store all of the domain constants.
   9 !                                    4. CALL alloc_space_field.
  10
  11 !  alloc_space_field                 1. Allocate space for the gridded data required for
  12 !                                       each domain.
  13
  14 !  dealloc_space_domain              1. Reconnect linked list nodes since the current
  15 !                                       node is removed.
  16 !                                    2. CALL dealloc_space_field.
  17 !                                    3. Deallocate single domain.
  18
  19 !  dealloc_space_field               1. Deallocate each of the fields for a particular
  20 !                                       domain.
  21
  22 !  first_loc_integer                 1. Find the first incidence of a particular
  23 !                                       domain identifier from an array of domain
  24 !                                       identifiers.
  25
  26 MODULE module_domain
  27
  28    USE module_driver_constants
  29    USE module_machine
  30    USE module_configure
  31    USE module_wrf_error
  32    USE module_utility
  33    USE module_domain_type
  34
  35    ! In WRFV3, the module_domain_type is defined
  36    ! in a separaate source file, frame/module_domain_type.F
  37    ! This enables splitting off the alloc_space_field routine
  38    ! into a separate file, reducing the size of module_domain
  39
  40    !  Now that a "domain" TYPE exists, we can use it to store a few pointers
  41    !  to this type.  These are primarily for use in traversing the linked list.
  42    !  The "head_grid" is always the pointer to the first domain that is
  43    !  allocated.  This is available and is not to be changed.  The others are
  44    !  just temporary pointers.
  45
  46    TYPE(domain) , POINTER :: head_grid , new_grid , next_grid , old_grid
  47
  48    !  To facilitate an easy integration of each of the domains that are on the
  49    !  same level, we have an array for the head pointer for each level.  This
  50    !  removed the need to search through the linked list at each time step to
  51    !  find which domains are to be active.
  52
  53    TYPE domain_levels
  54       TYPE(domain) , POINTER                              :: first_domain
  55    END TYPE domain_levels
  56
  57    TYPE(domain_levels) , DIMENSION(max_levels)            :: head_for_each_level
  58
  59    ! Use this to support debugging features, giving easy access to clock, etc.
  60    TYPE(domain), POINTER :: current_grid
  61    LOGICAL, SAVE :: current_grid_set = .FALSE.
  62
  63    ! internal routines
  64    PRIVATE domain_time_test_print
  65    PRIVATE test_adjust_io_timestr
  66
  67    INTERFACE get_ijk_from_grid
  68      MODULE PROCEDURE get_ijk_from_grid1, get_ijk_from_grid2
  69    END INTERFACE
  70
  71    INTEGER, PARAMETER :: max_hst_mods = 1000
  72
  73 CONTAINS
  74
  75    SUBROUTINE adjust_domain_dims_for_move( grid , dx, dy )
  76     IMPLICIT NONE
  77
  78     TYPE( domain ), POINTER   :: grid
  79     INTEGER, INTENT(IN) ::  dx, dy
  80
  81     data_ordering : SELECT CASE ( model_data_order )
  82        CASE  ( DATA_ORDER_XYZ )
  83             grid%sm31  = grid%sm31 + dx
  84             grid%em31  = grid%em31 + dx
  85             grid%sm32  = grid%sm32 + dy
  86             grid%em32  = grid%em32 + dy
  87             grid%sp31  = grid%sp31 + dx
  88             grid%ep31  = grid%ep31 + dx
  89             grid%sp32  = grid%sp32 + dy
  90             grid%ep32  = grid%ep32 + dy
  91             grid%sd31  = grid%sd31 + dx
  92             grid%ed31  = grid%ed31 + dx
  93             grid%sd32  = grid%sd32 + dy
  94             grid%ed32  = grid%ed32 + dy
  95
  96        CASE  ( DATA_ORDER_YXZ )
  97             grid%sm31  = grid%sm31 + dy
  98             grid%em31  = grid%em31 + dy
  99             grid%sm32  = grid%sm32 + dx
 100             grid%em32  = grid%em32 + dx
 101             grid%sp31  = grid%sp31 + dy
 102             grid%ep31  = grid%ep31 + dy
 103             grid%sp32  = grid%sp32 + dx
 104             grid%ep32  = grid%ep32 + dx
 105             grid%sd31  = grid%sd31 + dy
 106             grid%ed31  = grid%ed31 + dy
 107             grid%sd32  = grid%sd32 + dx
 108             grid%ed32  = grid%ed32 + dx
 109
 110        CASE  ( DATA_ORDER_ZXY )
 111             grid%sm32  = grid%sm32 + dx
 112             grid%em32  = grid%em32 + dx
 113             grid%sm33  = grid%sm33 + dy
 114             grid%em33  = grid%em33 + dy
 115             grid%sp32  = grid%sp32 + dx
 116             grid%ep32  = grid%ep32 + dx
 117             grid%sp33  = grid%sp33 + dy
 118             grid%ep33  = grid%ep33 + dy
 119             grid%sd32  = grid%sd32 + dx
 120             grid%ed32  = grid%ed32 + dx
 121             grid%sd33  = grid%sd33 + dy
 122             grid%ed33  = grid%ed33 + dy
 123
 124        CASE  ( DATA_ORDER_ZYX )
 125             grid%sm32  = grid%sm32 + dy
 126             grid%em32  = grid%em32 + dy
 127             grid%sm33  = grid%sm33 + dx
 128             grid%em33  = grid%em33 + dx
 129             grid%sp32  = grid%sp32 + dy
 130             grid%ep32  = grid%ep32 + dy
 131             grid%sp33  = grid%sp33 + dx
 132             grid%ep33  = grid%ep33 + dx
 133             grid%sd32  = grid%sd32 + dy
 134             grid%ed32  = grid%ed32 + dy
 135             grid%sd33  = grid%sd33 + dx
 136             grid%ed33  = grid%ed33 + dx
 137
 138        CASE  ( DATA_ORDER_XZY )
 139             grid%sm31  = grid%sm31 + dx
 140             grid%em31  = grid%em31 + dx
 141             grid%sm33  = grid%sm33 + dy
 142             grid%em33  = grid%em33 + dy
 143             grid%sp31  = grid%sp31 + dx
 144             grid%ep31  = grid%ep31 + dx
 145             grid%sp33  = grid%sp33 + dy
 146             grid%ep33  = grid%ep33 + dy
 147             grid%sd31  = grid%sd31 + dx
 148             grid%ed31  = grid%ed31 + dx
 149             grid%sd33  = grid%sd33 + dy
 150             grid%ed33  = grid%ed33 + dy
 151
 152        CASE  ( DATA_ORDER_YZX )
 153             grid%sm31  = grid%sm31 + dy
 154             grid%em31  = grid%em31 + dy
 155             grid%sm33  = grid%sm33 + dx
 156             grid%em33  = grid%em33 + dx
 157             grid%sp31  = grid%sp31 + dy
 158             grid%ep31  = grid%ep31 + dy
 159             grid%sp33  = grid%sp33 + dx
 160             grid%ep33  = grid%ep33 + dx
 161             grid%sd31  = grid%sd31 + dy
 162             grid%ed31  = grid%ed31 + dy
 163             grid%sd33  = grid%sd33 + dx
 164             grid%ed33  = grid%ed33 + dx
 165
 166     END SELECT data_ordering
 167
 168 #if 0
 169     CALL dealloc_space_field ( grid )
 170
 171     CALL alloc_space_field ( grid, grid%id , 1 , 2 , .FALSE. ,     &
 172                              grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
 173                              grid%sm31,  grid%em31,  grid%sm32,  grid%em32,  grid%sm33,  grid%em33, &
 174                              grid%sp31,  grid%ep31,  grid%sp32,  grid%ep32,  grid%sp33,  grid%ep33, &
 175                              grid%sp31x, grid%ep31x, grid%sp32x, grid%ep32x, grid%sp33x, grid%ep33x, &
 176                              grid%sp31y, grid%ep31y, grid%sp32y, grid%ep32y, grid%sp33y, grid%ep33y, &
 177                              grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, &   ! x-xpose
 178                              grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y  &   ! y-xpose
 179       )
 180 #endif
 181
 182     RETURN
 183    END SUBROUTINE adjust_domain_dims_for_move
 184
 185 #if 1
 186    SUBROUTINE get_ijk_from_grid1 (  grid ,                   &
 187                            ids, ide, jds, jde, kds, kde,    &
 188                            ims, ime, jms, jme, kms, kme,    &
 189                            ips, ipe, jps, jpe, kps, kpe,    &
 190                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
 191                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
 192                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
 193                            ipsy, ipey, jpsy, jpey, kpsy, kpey )
 194     IMPLICIT NONE
 195     TYPE( domain ), INTENT (IN)  :: grid
 196     INTEGER, INTENT(OUT) ::                                 &
 197                            ids, ide, jds, jde, kds, kde,    &
 198                            ims, ime, jms, jme, kms, kme,    &
 199                            ips, ipe, jps, jpe, kps, kpe,    &
 200                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
 201                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
 202                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
 203                            ipsy, ipey, jpsy, jpey, kpsy, kpey
 204
 205      CALL get_ijk_from_grid2 (  grid ,                   &
 206                            ids, ide, jds, jde, kds, kde,    &
 207                            ims, ime, jms, jme, kms, kme,    &
 208                            ips, ipe, jps, jpe, kps, kpe )
 209      data_ordering : SELECT CASE ( model_data_order )
 210        CASE  ( DATA_ORDER_XYZ )
 211            imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
 212            ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
 213            imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
 214            ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
 215        CASE  ( DATA_ORDER_YXZ )
 216            imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
 217            ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
 218            imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
 219            ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
 220        CASE  ( DATA_ORDER_ZXY )
 221            imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
 222            ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
 223            imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
 224            ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
 225        CASE  ( DATA_ORDER_ZYX )
 226            imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
 227            ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
 228            imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
 229            ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
 230        CASE  ( DATA_ORDER_XZY )
 231            imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
 232            ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
 233            imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
 234            ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
 235        CASE  ( DATA_ORDER_YZX )
 236            imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
 237            ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
 238            imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
 239            ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
 240      END SELECT data_ordering
 241    END SUBROUTINE get_ijk_from_grid1
 242
 243    SUBROUTINE get_ijk_from_grid2 (  grid ,                   &
 244                            ids, ide, jds, jde, kds, kde,    &
 245                            ims, ime, jms, jme, kms, kme,    &
 246                            ips, ipe, jps, jpe, kps, kpe )
 247
 248     IMPLICIT NONE
 249
 250     TYPE( domain ), INTENT (IN)  :: grid
 251     INTEGER, INTENT(OUT) ::                                 &
 252                            ids, ide, jds, jde, kds, kde,    &
 253                            ims, ime, jms, jme, kms, kme,    &
 254                            ips, ipe, jps, jpe, kps, kpe
 255
 256     data_ordering : SELECT CASE ( model_data_order )
 257        CASE  ( DATA_ORDER_XYZ )
 258            ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd33 ; kde = grid%ed33 ;
 259            ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm33 ; kme = grid%em33 ;
 260            ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp33 ; kpe = grid%ep33 ;
 261        CASE  ( DATA_ORDER_YXZ )
 262            ids = grid%sd32  ; ide = grid%ed32  ; jds = grid%sd31  ; jde = grid%ed31  ; kds = grid%sd33  ; kde = grid%ed33  ;
 263            ims = grid%sm32  ; ime = grid%em32  ; jms = grid%sm31  ; jme = grid%em31  ; kms = grid%sm33  ; kme = grid%em33  ;
 264            ips = grid%sp32  ; ipe = grid%ep32  ; jps = grid%sp31  ; jpe = grid%ep31  ; kps = grid%sp33  ; kpe = grid%ep33  ;
 265        CASE  ( DATA_ORDER_ZXY )
 266            ids = grid%sd32  ; ide = grid%ed32  ; jds = grid%sd33  ; jde = grid%ed33  ; kds = grid%sd31  ; kde = grid%ed31  ;
 267            ims = grid%sm32  ; ime = grid%em32  ; jms = grid%sm33  ; jme = grid%em33  ; kms = grid%sm31  ; kme = grid%em31  ;
 268            ips = grid%sp32  ; ipe = grid%ep32  ; jps = grid%sp33  ; jpe = grid%ep33  ; kps = grid%sp31  ; kpe = grid%ep31  ;
 269        CASE  ( DATA_ORDER_ZYX )
 270            ids = grid%sd33  ; ide = grid%ed33  ; jds = grid%sd32  ; jde = grid%ed32  ; kds = grid%sd31  ; kde = grid%ed31  ;
 271            ims = grid%sm33  ; ime = grid%em33  ; jms = grid%sm32  ; jme = grid%em32  ; kms = grid%sm31  ; kme = grid%em31  ;
 272            ips = grid%sp33  ; ipe = grid%ep33  ; jps = grid%sp32  ; jpe = grid%ep32  ; kps = grid%sp31  ; kpe = grid%ep31  ;
 273        CASE  ( DATA_ORDER_XZY )
 274            ids = grid%sd31  ; ide = grid%ed31  ; jds = grid%sd33  ; jde = grid%ed33  ; kds = grid%sd32  ; kde = grid%ed32  ;
 275            ims = grid%sm31  ; ime = grid%em31  ; jms = grid%sm33  ; jme = grid%em33  ; kms = grid%sm32  ; kme = grid%em32  ;
 276            ips = grid%sp31  ; ipe = grid%ep31  ; jps = grid%sp33  ; jpe = grid%ep33  ; kps = grid%sp32  ; kpe = grid%ep32  ;
 277        CASE  ( DATA_ORDER_YZX )
 278            ids = grid%sd33  ; ide = grid%ed33  ; jds = grid%sd31  ; jde = grid%ed31  ; kds = grid%sd32  ; kde = grid%ed32  ;
 279            ims = grid%sm33  ; ime = grid%em33  ; jms = grid%sm31  ; jme = grid%em31  ; kms = grid%sm32  ; kme = grid%em32  ;
 280            ips = grid%sp33  ; ipe = grid%ep33  ; jps = grid%sp31  ; jpe = grid%ep31  ; kps = grid%sp32  ; kpe = grid%ep32  ;
 281     END SELECT data_ordering
 282    END SUBROUTINE get_ijk_from_grid2
 283
 284 ! return the values for subgrid whose refinement is in grid%sr
 285 ! note when using this routine, it does not affect K. For K
 286 ! (vertical), it just returns what get_ijk_from_grid does
 287    SUBROUTINE get_ijk_from_subgrid (  grid ,                &
 288                            ids0, ide0, jds0, jde0, kds0, kde0,    &
 289                            ims0, ime0, jms0, jme0, kms0, kme0,    &
 290                            ips0, ipe0, jps0, jpe0, kps0, kpe0    )
 291     TYPE( domain ), INTENT (IN)  :: grid
 292     INTEGER, INTENT(OUT) ::                                 &
 293                            ids0, ide0, jds0, jde0, kds0, kde0,    &
 294                            ims0, ime0, jms0, jme0, kms0, kme0,    &
 295                            ips0, ipe0, jps0, jpe0, kps0, kpe0
 296    ! Local
 297     INTEGER              ::                                 &
 298                            ids, ide, jds, jde, kds, kde,    &
 299                            ims, ime, jms, jme, kms, kme,    &
 300                            ips, ipe, jps, jpe, kps, kpe
 301      CALL get_ijk_from_grid (  grid ,                         &
 302                              ids, ide, jds, jde, kds, kde,    &
 303                              ims, ime, jms, jme, kms, kme,    &
 304                              ips, ipe, jps, jpe, kps, kpe    )
 305      ids0 = ids
 306      ide0 = ide * grid%sr_x
 307      ims0 = (ims-1)*grid%sr_x+1
 308      ime0 = ime * grid%sr_x
 309      ips0 = (ips-1)*grid%sr_x+1
 310      ipe0 = ipe * grid%sr_x
 311
 312      jds0 = jds
 313      jde0 = jde * grid%sr_y
 314      jms0 = (jms-1)*grid%sr_y+1
 315      jme0 = jme * grid%sr_y
 316      jps0 = (jps-1)*grid%sr_y+1
 317      jpe0 = jpe * grid%sr_y
 318
 319      kds0 = kds
 320      kde0 = kde
 321      kms0 = kms
 322      kme0 = kme
 323      kps0 = kps
 324      kpe0 = kpe
 325    RETURN
 326    END SUBROUTINE get_ijk_from_subgrid
 327 #endif
 328
 329 ! Default version ; Otherwise module containing interface to DM library will provide
 330
 331    SUBROUTINE wrf_patch_domain( id , domdesc , parent, parent_id , parent_domdesc , &
 332                             sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
 333                             sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
 334                             sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
 335                                         sp1x , ep1x , sm1x , em1x , &
 336                                         sp2x , ep2x , sm2x , em2x , &
 337                                         sp3x , ep3x , sm3x , em3x , &
 338                                         sp1y , ep1y , sm1y , em1y , &
 339                                         sp2y , ep2y , sm2y , em2y , &
 340                                         sp3y , ep3y , sm3y , em3y , &
 341                             bdx , bdy , bdy_mask )
 342 !<DESCRIPTION>
 343 ! Wrf_patch_domain is called as part of the process of initiating a new
 344 ! domain.  Based on the global domain dimension information that is
 345 ! passed in it computes the patch and memory dimensions on this
 346 ! distributed-memory process for parallel compilation when DM_PARALLEL is
 347 ! defined in configure.wrf.  In this case, it relies on an external
 348 ! communications package-contributed routine, wrf_dm_patch_domain. For
 349 ! non-parallel compiles, it returns the patch and memory dimensions based
 350 ! on the entire domain. In either case, the memory dimensions will be
 351 ! larger than the patch dimensions, since they allow for distributed
 352 ! memory halo regions (DM_PARALLEL only) and for boundary regions around
 353 ! the domain (used for idealized cases only).  The width of the boundary
 354 ! regions to be accommodated is passed in as bdx and bdy.
 355 !
 356 ! The bdy_mask argument is a four-dimensional logical array, each element
 357 ! of which is set to true for any boundaries that this process's patch
 358 ! contains (all four are true in the non-DM_PARALLEL case) and false
 359 ! otherwise. The indices into the bdy_mask are defined in
 360 ! frame/module_state_description.F. P_XSB corresponds boundary that
 361 ! exists at the beginning of the X-dimension; ie. the western boundary;
 362 ! P_XEB to the boundary that corresponds to the end of the X-dimension
 363 ! (east). Likewise for Y (south and north respectively).
 364 !
 365 ! The correspondence of the first, second, and third dimension of each
 366 ! set (domain, memory, and patch) with the coordinate axes of the model
 367 ! domain is based on the setting of the variable model_data_order, which
 368 ! comes into this routine through USE association of
 369 ! module_driver_constants in the enclosing module of this routine,
 370 ! module_domain.  Model_data_order is defined by the Registry, based on
 371 ! the dimspec entries which associate dimension specifiers (e.g. 'k') in
 372 ! the Registry with a coordinate axis and specify which dimension of the
 373 ! arrays they represent. For WRF, the sd1 , ed1 , sp1 , ep1 , sm1 , and
 374 ! em1 correspond to the starts and ends of the global, patch, and memory
 375 ! dimensions in X; those with 2 specify Z (vertical); and those with 3
 376 ! specify Y.  Note that the WRF convention is to overdimension to allow
 377 ! for staggered fields so that sd<em>n</em>:ed<em>n</em> are the starts
 378 ! and ends of the staggered domains in X.  The non-staggered grid runs
 379 ! sd<em>n</em>:ed<em>n</em>-1. The extra row or column on the north or
 380 ! east boundaries is not used for non-staggered fields.
 381 !
 382 ! The domdesc and parent_domdesc arguments are for external communication
 383 ! packages (e.g. RSL) that establish and return to WRF integer handles
 384 ! for referring to operations on domains.  These descriptors are not set
 385 ! or used otherwise and they are opaque, which means they are never
 386 ! accessed or modified in WRF; they are only only passed between calls to
 387 ! the external package.
 388 !</DESCRIPTION>
 389
 390    USE module_machine
 391    IMPLICIT NONE
 392    LOGICAL, DIMENSION(4), INTENT(OUT)  :: bdy_mask
 393    INTEGER, INTENT(IN)   :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
 394    INTEGER, INTENT(OUT)  :: sp1  , ep1  , sp2  , ep2  , sp3  , ep3  , &  ! z-xpose (std)
 395                             sm1  , em1  , sm2  , em2  , sm3  , em3
 396    INTEGER, INTENT(OUT)  :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &  ! x-xpose
 397                             sm1x , em1x , sm2x , em2x , sm3x , em3x
 398    INTEGER, INTENT(OUT)  :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &  ! y-xpose
 399                             sm1y , em1y , sm2y , em2y , sm3y , em3y
 400    INTEGER, INTENT(IN)   :: id , parent_id , parent_domdesc
 401    INTEGER, INTENT(INOUT)  :: domdesc
 402    TYPE(domain), POINTER :: parent
 403
 404 !local data
 405
 406    INTEGER spec_bdy_width
 407
 408    CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
 409
 410 #ifndef DM_PARALLEL
 411
 412    bdy_mask = .true.     ! only one processor so all 4 boundaries are there
 413
 414 ! this is a trivial version -- 1 patch per processor;
 415 ! use version in module_dm to compute for DM
 416    sp1 = sd1 ; sp2 = sd2 ; sp3 = sd3
 417    ep1 = ed1 ; ep2 = ed2 ; ep3 = ed3
 418    SELECT CASE ( model_data_order )
 419       CASE ( DATA_ORDER_XYZ )
 420          sm1  = sp1 - bdx ; em1 = ep1 + bdx
 421          sm2  = sp2 - bdy ; em2 = ep2 + bdy
 422          sm3  = sp3       ; em3 = ep3
 423       CASE ( DATA_ORDER_YXZ )
 424          sm1 = sp1 - bdy ; em1 = ep1 + bdy
 425          sm2 = sp2 - bdx ; em2 = ep2 + bdx
 426          sm3 = sp3       ; em3 = ep3
 427       CASE ( DATA_ORDER_ZXY )
 428          sm1 = sp1       ; em1 = ep1
 429          sm2 = sp2 - bdx ; em2 = ep2 + bdx
 430          sm3 = sp3 - bdy ; em3 = ep3 + bdy
 431       CASE ( DATA_ORDER_ZYX )
 432          sm1 = sp1       ; em1 = ep1
 433          sm2 = sp2 - bdy ; em2 = ep2 + bdy
 434          sm3 = sp3 - bdx ; em3 = ep3 + bdx
 435       CASE ( DATA_ORDER_XZY )
 436          sm1 = sp1 - bdx ; em1 = ep1 + bdx
 437          sm2 = sp2       ; em2 = ep2
 438          sm3 = sp3 - bdy ; em3 = ep3 + bdy
 439       CASE ( DATA_ORDER_YZX )
 440          sm1 = sp1 - bdy ; em1 = ep1 + bdy
 441          sm2 = sp2       ; em2 = ep2
 442          sm3 = sp3 - bdx ; em3 = ep3 + bdx
 443    END SELECT
 444    sm1x = sm1       ; em1x = em1    ! just copy
 445    sm2x = sm2       ; em2x = em2
 446    sm3x = sm3       ; em3x = em3
 447    sm1y = sm1       ; em1y = em1    ! just copy
 448    sm2y = sm2       ; em2y = em2
 449    sm3y = sm3       ; em3y = em3
 450 ! assigns mostly just to suppress warning messages that INTENT OUT vars not assigned
 451    sp1x = sp1 ; ep1x = ep1 ; sp2x = sp2 ; ep2x = ep2 ; sp3x = sp3 ; ep3x = ep3
 452    sp1y = sp1 ; ep1y = ep1 ; sp2y = sp2 ; ep2y = ep2 ; sp3y = sp3 ; ep3y = ep3
 453
 454 #else
 455 ! This is supplied by the package specific version of module_dm, which
 456 ! is supplied by the external package and copied into the src directory
 457 ! when the code is compiled. The cp command will be found in the externals
 458 ! target of the configure.wrf file for this architecture.  Eg: for RSL
 459 ! routine is defined in external/RSL/module_dm.F .
 460 ! Note, it would be very nice to be able to pass parent to this routine;
 461 ! however, there doesn't seem to be a way to do that in F90. That is because
 462 ! to pass a pointer to a domain structure, this call requires an interface
 463 ! definition for wrf_dm_patch_domain (otherwise it will try to convert the
 464 ! pointer to something). In order to provide an interface definition, we
 465 ! would need to either USE module_dm or use an interface block. In either
 466 ! case it generates a circular USE reference, since module_dm uses
 467 ! module_domain.  JM 20020416
 468
 469    CALL wrf_dm_patch_domain( id , domdesc , parent_id , parent_domdesc , &
 470                              sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
 471                              sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
 472                              sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
 473                                          sp1x , ep1x , sm1x , em1x , &
 474                                          sp2x , ep2x , sm2x , em2x , &
 475                                          sp3x , ep3x , sm3x , em3x , &
 476                                          sp1y , ep1y , sm1y , em1y , &
 477                                          sp2y , ep2y , sm2y , em2y , &
 478                                          sp3y , ep3y , sm3y , em3y , &
 479                              bdx , bdy )
 480
 481    SELECT CASE ( model_data_order )
 482       CASE ( DATA_ORDER_XYZ )
 483    bdy_mask( P_XSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
 484    bdy_mask( P_YSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
 485    bdy_mask( P_XEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
 486    bdy_mask( P_YEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
 487       CASE ( DATA_ORDER_YXZ )
 488    bdy_mask( P_XSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
 489    bdy_mask( P_YSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
 490    bdy_mask( P_XEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
 491    bdy_mask( P_YEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
 492       CASE ( DATA_ORDER_ZXY )
 493    bdy_mask( P_XSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
 494    bdy_mask( P_YSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
 495    bdy_mask( P_XEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
 496    bdy_mask( P_YEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
 497       CASE ( DATA_ORDER_ZYX )
 498    bdy_mask( P_XSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
 499    bdy_mask( P_YSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
 500    bdy_mask( P_XEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
 501    bdy_mask( P_YEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
 502       CASE ( DATA_ORDER_XZY )
 503    bdy_mask( P_XSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
 504    bdy_mask( P_YSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
 505    bdy_mask( P_XEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
 506    bdy_mask( P_YEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
 507       CASE ( DATA_ORDER_YZX )
 508    bdy_mask( P_XSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
 509    bdy_mask( P_YSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
 510    bdy_mask( P_XEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
 511    bdy_mask( P_YEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
 512    END SELECT
 513
 514 #endif
 515
 516    RETURN
 517    END SUBROUTINE wrf_patch_domain
 518 !
 519    SUBROUTINE alloc_and_configure_domain ( domain_id , active_this_task, grid , parent, kid )
 520
 521 !<DESCRIPTION>
 522 ! This subroutine is used to allocate a domain data structure of
 523 ! TYPE(DOMAIN) pointed to by the argument <em>grid</em>, link it into the
 524 ! nested domain hierarchy, and set it's configuration information from
 525 ! the appropriate settings in the WRF namelist file. Specifically, if the
 526 ! domain being allocated and configured is nest, the <em>parent</em>
 527 ! argument will point to the already existing domain data structure for
 528 ! the parent domain and the <em>kid</em> argument will be set to an
 529 ! integer indicating which child of the parent this grid will be (child
 530 ! indices start at 1).  If this is the top-level domain, the parent and
 531 ! kid arguments are ignored.  <b>WRF domains may have multiple children
 532 ! but only ever have one parent.</b>
 533 !
 534 ! The <em>domain_id</em> argument is the
 535 ! integer handle by which this new domain will be referred; it comes from
 536 ! the grid_id setting in the namelist, and these grid ids correspond to
 537 ! the ordering of settings in the namelist, starting with 1 for the
 538 ! top-level domain. The id of 1 always corresponds to the top-level
 539 ! domain.  and these grid ids correspond to the ordering of settings in
 540 ! the namelist, starting with 1 for the top-level domain.
 541 !
 542 ! Model_data_order is provide by USE association of
 543 ! module_driver_constants and is set from dimspec entries in the
 544 ! Registry.
 545 !
 546 ! The allocation of the TYPE(DOMAIN) itself occurs in this routine.
 547 ! However, the numerous multi-dimensional arrays that make up the members
 548 ! of the domain are allocated in the call to alloc_space_field, after
 549 ! wrf_patch_domain has been called to determine the dimensions in memory
 550 ! that should be allocated.  It bears noting here that arrays and code
 551 ! that indexes these arrays are always global, regardless of how the
 552 ! model is decomposed over patches. Thus, when arrays are allocated on a
 553 ! given process, the start and end of an array dimension are the global
 554 ! indices of the start and end of that process's subdomain.
 555 !
 556 ! Configuration information for the domain (that is, information from the
 557 ! namelist) is added by the call to <a href=med_add_config_info_to_grid.html>med_add_config_info_to_grid</a>, defined
 558 ! in share/mediation_wrfmain.F.
 559 !</DESCRIPTION>
 560
 561       IMPLICIT NONE
 562
 563       !  Input data.
 564
 565       INTEGER , INTENT(IN)            :: domain_id
 566       LOGICAL , OPTIONAL, INTENT(IN)  :: active_this_task ! false if domain is being handled by other MPI tasks
 567       TYPE( domain ) , POINTER        :: grid
 568       TYPE( domain ) , POINTER        :: parent
 569       INTEGER , INTENT(IN)            :: kid    ! which kid of parent am I?
 570
 571       !  Local data.
 572       INTEGER                     :: sd1 , ed1 , sp1 , ep1 , sm1 , em1
 573       INTEGER                     :: sd2 , ed2 , sp2 , ep2 , sm2 , em2
 574       INTEGER                     :: sd3 , ed3 , sp3 , ep3 , sm3 , em3
 575
 576       INTEGER                     :: sd1x , ed1x , sp1x , ep1x , sm1x , em1x
 577       INTEGER                     :: sd2x , ed2x , sp2x , ep2x , sm2x , em2x
 578       INTEGER                     :: sd3x , ed3x , sp3x , ep3x , sm3x , em3x
 579
 580       INTEGER                     :: sd1y , ed1y , sp1y , ep1y , sm1y , em1y
 581       INTEGER                     :: sd2y , ed2y , sp2y , ep2y , sm2y , em2y
 582       INTEGER                     :: sd3y , ed3y , sp3y , ep3y , sm3y , em3y
 583
 584       TYPE(domain) , POINTER      :: new_grid
 585       INTEGER                     :: i
 586       INTEGER                     :: parent_id , parent_domdesc , new_domdesc
 587       INTEGER                     :: bdyzone_x , bdyzone_y
 588       INTEGER                     :: nx, ny
 589       LOGICAL :: active
 590
 591 !
 592       active = .TRUE.
 593       IF ( PRESENT( active_this_task ) ) THEN
 594          active = active_this_task
 595       ENDIF
 596
 597 ! This next step uses information that is listed in the registry as namelist_derived
 598 ! to properly size the domain and the patches; this in turn is stored in the new_grid
 599 ! data structure
 600
 601
 602       data_ordering : SELECT CASE ( model_data_order )
 603         CASE  ( DATA_ORDER_XYZ )
 604
 605           CALL nl_get_s_we( domain_id , sd1 )
 606           CALL nl_get_e_we( domain_id , ed1 )
 607           CALL nl_get_s_sn( domain_id , sd2 )
 608           CALL nl_get_e_sn( domain_id , ed2 )
 609           CALL nl_get_s_vert( domain_id , sd3 )
 610           CALL nl_get_e_vert( domain_id , ed3 )
 611           nx = ed1-sd1+1
 612           ny = ed2-sd2+1
 613
 614         CASE  ( DATA_ORDER_YXZ )
 615
 616           CALL nl_get_s_sn( domain_id , sd1 )
 617           CALL nl_get_e_sn( domain_id , ed1 )
 618           CALL nl_get_s_we( domain_id , sd2 )
 619           CALL nl_get_e_we( domain_id , ed2 )
 620           CALL nl_get_s_vert( domain_id , sd3 )
 621           CALL nl_get_e_vert( domain_id , ed3 )
 622           nx = ed2-sd2+1
 623           ny = ed1-sd1+1
 624
 625         CASE  ( DATA_ORDER_ZXY )
 626
 627           CALL nl_get_s_vert( domain_id , sd1 )
 628           CALL nl_get_e_vert( domain_id , ed1 )
 629           CALL nl_get_s_we( domain_id , sd2 )
 630           CALL nl_get_e_we( domain_id , ed2 )
 631           CALL nl_get_s_sn( domain_id , sd3 )
 632           CALL nl_get_e_sn( domain_id , ed3 )
 633           nx = ed2-sd2+1
 634           ny = ed3-sd3+1
 635
 636         CASE  ( DATA_ORDER_ZYX )
 637
 638           CALL nl_get_s_vert( domain_id , sd1 )
 639           CALL nl_get_e_vert( domain_id , ed1 )
 640           CALL nl_get_s_sn( domain_id , sd2 )
 641           CALL nl_get_e_sn( domain_id , ed2 )
 642           CALL nl_get_s_we( domain_id , sd3 )
 643           CALL nl_get_e_we( domain_id , ed3 )
 644           nx = ed3-sd3+1
 645           ny = ed2-sd2+1
 646
 647         CASE  ( DATA_ORDER_XZY )
 648
 649           CALL nl_get_s_we( domain_id , sd1 )
 650           CALL nl_get_e_we( domain_id , ed1 )
 651           CALL nl_get_s_vert( domain_id , sd2 )
 652           CALL nl_get_e_vert( domain_id , ed2 )
 653           CALL nl_get_s_sn( domain_id , sd3 )
 654           CALL nl_get_e_sn( domain_id , ed3 )
 655           nx = ed1-sd1+1
 656           ny = ed3-sd3+1
 657
 658         CASE  ( DATA_ORDER_YZX )
 659
 660           CALL nl_get_s_sn( domain_id , sd1 )
 661           CALL nl_get_e_sn( domain_id , ed1 )
 662           CALL nl_get_s_vert( domain_id , sd2 )
 663           CALL nl_get_e_vert( domain_id , ed2 )
 664           CALL nl_get_s_we( domain_id , sd3 )
 665           CALL nl_get_e_we( domain_id , ed3 )
 666           nx = ed3-sd3+1
 667           ny = ed1-sd1+1
 668
 669       END SELECT data_ordering
 670
 671       IF ( num_time_levels > 3 ) THEN
 672         WRITE ( wrf_err_message , * ) 'alloc_and_configure_domain: ', &
 673           'Incorrect value for num_time_levels ', num_time_levels
 674         CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
 675       ENDIF
 676
 677       IF (ASSOCIATED(parent)) THEN
 678         parent_id = parent%id
 679         parent_domdesc = parent%domdesc
 680       ELSE
 681         parent_id = -1
 682         parent_domdesc = -1
 683       ENDIF
 684
 685 ! provided by application, WRF defines in share/module_bc.F
 686       CALL get_bdyzone_x( bdyzone_x )
 687       CALL get_bdyzone_y( bdyzone_y )
 688
 689       ALLOCATE ( new_grid )
 690       ALLOCATE( new_grid%head_statevars )
 691       new_grid%head_statevars%Ndim = 0
 692       NULLIFY( new_grid%head_statevars%next)
 693       new_grid%tail_statevars => new_grid%head_statevars
 694
 695       ALLOCATE ( new_grid%parents( max_parents ) )
 696       ALLOCATE ( new_grid%nests( max_nests ) )
 697       NULLIFY( new_grid%sibling )
 698       DO i = 1, max_nests
 699          NULLIFY( new_grid%nests(i)%ptr )
 700       ENDDO
 701       NULLIFY  (new_grid%next)
 702       NULLIFY  (new_grid%same_level)
 703       NULLIFY  (new_grid%i_start)
 704       NULLIFY  (new_grid%j_start)
 705       NULLIFY  (new_grid%i_end)
 706       NULLIFY  (new_grid%j_end)
 707       ALLOCATE( new_grid%domain_clock )
 708       new_grid%domain_clock_created = .FALSE.
 709       ALLOCATE( new_grid%alarms( MAX_WRF_ALARMS ) )    ! initialize in setup_timekeeping
 710       ALLOCATE( new_grid%alarms_created( MAX_WRF_ALARMS ) )
 711       DO i = 1, MAX_WRF_ALARMS
 712         new_grid%alarms_created( i ) = .FALSE.
 713       ENDDO
 714       new_grid%time_set = .FALSE.
 715       new_grid%is_intermediate = .FALSE.
 716       new_grid%have_displayed_alloc_stats = .FALSE.
 717
 718       new_grid%tiling_latch = .FALSE.  ! 20121003
 719
 720       ! set up the pointers that represent the nest hierarchy
 721       ! set this up *prior* to calling the patching or allocation
 722       ! routines so that implementations of these routines can
 723       ! traverse the nest hierarchy (through the root head_grid)
 724       ! if they need to
 725
 726
 727       IF ( domain_id .NE. 1 ) THEN
 728          new_grid%parents(1)%ptr => parent
 729          new_grid%num_parents = 1
 730          parent%nests(kid)%ptr => new_grid
 731          new_grid%child_of_parent(1) = kid    ! note assumption that nest can have only 1 parent
 732          parent%num_nests = parent%num_nests + 1
 733       END IF
 734       new_grid%id = domain_id                 ! this needs to be assigned prior to calling wrf_patch_domain
 735       new_grid%active_this_task = active
 736
 737       CALL wrf_patch_domain( domain_id  , new_domdesc , parent, parent_id, parent_domdesc , &
 738
 739                              sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &     ! z-xpose dims
 740                              sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &     ! (standard)
 741                              sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
 742
 743                                      sp1x , ep1x , sm1x , em1x , &     ! x-xpose dims
 744                                      sp2x , ep2x , sm2x , em2x , &
 745                                      sp3x , ep3x , sm3x , em3x , &
 746
 747                                      sp1y , ep1y , sm1y , em1y , &     ! y-xpose dims
 748                                      sp2y , ep2y , sm2y , em2y , &
 749                                      sp3y , ep3y , sm3y , em3y , &
 750
 751                          bdyzone_x  , bdyzone_y , new_grid%bdy_mask &
 752       )
 753
 754
 755       new_grid%domdesc = new_domdesc
 756       new_grid%num_nests = 0
 757       new_grid%num_siblings = 0
 758       new_grid%num_parents = 0
 759       new_grid%max_tiles   = 0
 760       new_grid%num_tiles_spec   = 0
 761       new_grid%nframes   = 0         ! initialize the number of frames per file (array assignment)
 762 !BPR BEGIN
 763 !#if (EM_CORE == 1)
 764 !      new_grid%stepping_to_time = .FALSE.
 765 !      new_grid%adaptation_domain = 1
 766 !      new_grid%last_step_updated = -1
 767 !#endif
 768 !BPR BEGIN
 769
 770 !      IF (active) THEN
 771         ! only allocate state if this set of tasks actually computes that domain, jm 20140822
 772       new_grid%active_this_task = active
 773       CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. , active,     &
 774                                sd1, ed1, sd2, ed2, sd3, ed3,       &
 775                                sm1,  em1,  sm2,  em2,  sm3,  em3,  &
 776                                sp1,  ep1,  sp2,  ep2,  sp3,  ep3,  &
 777                                sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
 778                                sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
 779                                sm1x, em1x, sm2x, em2x, sm3x, em3x, &   ! x-xpose
 780                                sm1y, em1y, sm2y, em2y, sm3y, em3y  &   ! y-xpose
 781       )
 782 !      ELSE
 783 !        WRITE (wrf_err_message,*)"Not allocating storage for domain ",domain_id," on this set of tasks"
 784 !        CALL wrf_message(TRIM(wrf_err_message))
 785 !      ENDIF
 786
 787 !BPR BEGIN
 788 #if (EM_CORE == 1)
 789 !Set these here, after alloc_space_field, which initializes at least last_step_updated to zero
 790       new_grid%stepping_to_time = .FALSE.
 791       new_grid%adaptation_domain = 1
 792       new_grid%last_step_updated = -1
 793 #endif
 794 !BPR END
 795
 796 #if MOVE_NESTS
 797 !set these here, after alloc_space_field, which initializes vc_i, vc_j to zero
 798       new_grid%xi = -1.0
 799       new_grid%xj = -1.0
 800       new_grid%vc_i = -1.0
 801       new_grid%vc_j = -1.0
 802 #endif
 803
 804       new_grid%sd31                            = sd1
 805       new_grid%ed31                            = ed1
 806       new_grid%sp31                            = sp1
 807       new_grid%ep31                            = ep1
 808       new_grid%sm31                            = sm1
 809       new_grid%em31                            = em1
 810       new_grid%sd32                            = sd2
 811       new_grid%ed32                            = ed2
 812       new_grid%sp32                            = sp2
 813       new_grid%ep32                            = ep2
 814       new_grid%sm32                            = sm2
 815       new_grid%em32                            = em2
 816       new_grid%sd33                            = sd3
 817       new_grid%ed33                            = ed3
 818       new_grid%sp33                            = sp3
 819       new_grid%ep33                            = ep3
 820       new_grid%sm33                            = sm3
 821       new_grid%em33                            = em3
 822
 823       new_grid%sp31x                           = sp1x
 824       new_grid%ep31x                           = ep1x
 825       new_grid%sm31x                           = sm1x
 826       new_grid%em31x                           = em1x
 827       new_grid%sp32x                           = sp2x
 828       new_grid%ep32x                           = ep2x
 829       new_grid%sm32x                           = sm2x
 830       new_grid%em32x                           = em2x
 831       new_grid%sp33x                           = sp3x
 832       new_grid%ep33x                           = ep3x
 833       new_grid%sm33x                           = sm3x
 834       new_grid%em33x                           = em3x
 835
 836       new_grid%sp31y                           = sp1y
 837       new_grid%ep31y                           = ep1y
 838       new_grid%sm31y                           = sm1y
 839       new_grid%em31y                           = em1y
 840       new_grid%sp32y                           = sp2y
 841       new_grid%ep32y                           = ep2y
 842       new_grid%sm32y                           = sm2y
 843       new_grid%em32y                           = em2y
 844       new_grid%sp33y                           = sp3y
 845       new_grid%ep33y                           = ep3y
 846       new_grid%sm33y                           = sm3y
 847       new_grid%em33y                           = em3y
 848
 849       SELECT CASE ( model_data_order )
 850          CASE  ( DATA_ORDER_XYZ )
 851             new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
 852             new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
 853             new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
 854             new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
 855             new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
 856             new_grid%em21 = em1 ; new_grid%em22 = em2 ;
 857             new_grid%sd11 = sd1
 858             new_grid%ed11 = ed1
 859             new_grid%sp11 = sp1
 860             new_grid%ep11 = ep1
 861             new_grid%sm11 = sm1
 862             new_grid%em11 = em1
 863          CASE  ( DATA_ORDER_YXZ )
 864             new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
 865             new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
 866             new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
 867             new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
 868             new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
 869             new_grid%em21 = em1 ; new_grid%em22 = em2 ;
 870             new_grid%sd11 = sd1
 871             new_grid%ed11 = ed1
 872             new_grid%sp11 = sp1
 873             new_grid%ep11 = ep1
 874             new_grid%sm11 = sm1
 875             new_grid%em11 = em1
 876          CASE  ( DATA_ORDER_ZXY )
 877             new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
 878             new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
 879             new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
 880             new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
 881             new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
 882             new_grid%em21 = em2 ; new_grid%em22 = em3 ;
 883             new_grid%sd11 = sd2
 884             new_grid%ed11 = ed2
 885             new_grid%sp11 = sp2
 886             new_grid%ep11 = ep2
 887             new_grid%sm11 = sm2
 888             new_grid%em11 = em2
 889          CASE  ( DATA_ORDER_ZYX )
 890             new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
 891             new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
 892             new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
 893             new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
 894             new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
 895             new_grid%em21 = em2 ; new_grid%em22 = em3 ;
 896             new_grid%sd11 = sd2
 897             new_grid%ed11 = ed2
 898             new_grid%sp11 = sp2
 899             new_grid%ep11 = ep2
 900             new_grid%sm11 = sm2
 901             new_grid%em11 = em2
 902          CASE  ( DATA_ORDER_XZY )
 903             new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
 904             new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
 905             new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
 906             new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
 907             new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
 908             new_grid%em21 = em1 ; new_grid%em22 = em3 ;
 909             new_grid%sd11 = sd1
 910             new_grid%ed11 = ed1
 911             new_grid%sp11 = sp1
 912             new_grid%ep11 = ep1
 913             new_grid%sm11 = sm1
 914             new_grid%em11 = em1
 915          CASE  ( DATA_ORDER_YZX )
 916             new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
 917             new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
 918             new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
 919             new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
 920             new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
 921             new_grid%em21 = em1 ; new_grid%em22 = em3 ;
 922             new_grid%sd11 = sd1
 923             new_grid%ed11 = ed1
 924             new_grid%sp11 = sp1
 925             new_grid%ep11 = ep1
 926             new_grid%sm11 = sm1
 927             new_grid%em11 = em1
 928       END SELECT
 929
 930       CALL med_add_config_info_to_grid ( new_grid )           ! this is a mediation layer routine
 931
 932 ! Some miscellaneous state that is in the Registry but not namelist data
 933
 934       new_grid%tiled                           = .false.
 935       new_grid%patched                         = .false.
 936       NULLIFY(new_grid%mapping)
 937
 938 ! This next set of includes causes all but the namelist_derived variables to be
 939 ! properly assigned to the new_grid record
 940
 941       grid => new_grid
 942 !debug write(0,*)__FILE__,__LINE__,'grid%mvnest ',grid%mvnest
 943
 944 !debug write(0,*)__FILE__,__LINE__,'grid%mvnest ',grid%mvnest
 945       IF ( grid%active_this_task ) THEN
 946 ! Allocate storage for time series metadata
 947         ALLOCATE( grid%lattsloc( grid%max_ts_locs ) )
 948         ALLOCATE( grid%lontsloc( grid%max_ts_locs ) )
 949         ALLOCATE( grid%nametsloc( grid%max_ts_locs ) )
 950         ALLOCATE( grid%desctsloc( grid%max_ts_locs ) )
 951         ALLOCATE( grid%itsloc( grid%max_ts_locs ) )
 952         ALLOCATE( grid%jtsloc( grid%max_ts_locs ) )
 953         ALLOCATE( grid%id_tsloc( grid%max_ts_locs ) )
 954         ALLOCATE( grid%ts_filename( grid%max_ts_locs ) )
 955         grid%ntsloc        = 0
 956         grid%ntsloc_domain = 0
 957
 958 #if (EM_CORE == 1)
 959 ! Allocate storage for track metadata
 960         ALLOCATE( grid%track_time_in( grid%track_loc_in ) )
 961         ALLOCATE( grid%track_lat_in( grid%track_loc_in ) )
 962         ALLOCATE( grid%track_lon_in( grid%track_loc_in ) )
 963
 964         ALLOCATE( grid%track_time_domain( grid%track_loc_in ) )
 965         ALLOCATE( grid%track_lat_domain( grid%track_loc_in ) )
 966         ALLOCATE( grid%track_lon_domain( grid%track_loc_in ) )
 967         ALLOCATE( grid%track_i( grid%track_loc_in ) )
 968         ALLOCATE( grid%track_j( grid%track_loc_in ) )
 969
 970       grid%track_loc        = 0
 971       grid%track_loc_domain = 0
 972       grid%track_have_calculated = .FALSE.
 973       grid%track_have_input      = .FALSE.
 974 #endif
 975       ELSE
 976         WRITE (wrf_err_message,*)"Not allocating time series storage for domain ",domain_id," on this set of tasks"
 977         CALL wrf_message(TRIM(wrf_err_message))
 978       ENDIF
 979 !debug write(0,*)__FILE__,__LINE__,'grid%mvnest ',grid%mvnest
 980 #ifdef DM_PARALLEL
 981       CALL wrf_get_dm_communicator_for_id( grid%id, grid%communicator )
 982       CALL wrf_dm_define_comms( grid )
 983 #endif
 984
 985       grid%interp_mp = .true.
 986
 987    END SUBROUTINE alloc_and_configure_domain
 988
 989    SUBROUTINE get_fieldstr(ix,c,instr,outstr,noutstr,noerr)
 990      IMPLICIT NONE
 991      INTEGER, INTENT(IN)          :: ix
 992      CHARACTER*(*), INTENT(IN)    :: c
 993      CHARACTER*(*), INTENT(IN)    :: instr
 994      CHARACTER*(*), INTENT(OUT)   :: outstr
 995      INTEGER,       INTENT(IN)    :: noutstr  ! length of outstr
 996      LOGICAL,       INTENT(INOUT) :: noerr     ! status
 997      !local
 998      INTEGER, PARAMETER :: MAX_DEXES = 1000
 999      INTEGER I, PREV, IDEX
1000      INTEGER DEXES(MAX_DEXES)
1001      outstr = ""
1002      prev = 1
1003      dexes(1) = 1
1004      DO i = 2,MAX_DEXES
1005        idex = INDEX(instr(prev:LEN(TRIM(instr))),c)
1006        IF ( idex .GT. 0 ) THEN
1007          dexes(i) = idex+prev
1008          prev = dexes(i)+1
1009        ELSE
1010          dexes(i) = LEN(TRIM(instr))+2
1011        ENDIF
1012      ENDDO
1013
1014      IF     ( (dexes(ix+1)-2)-(dexes(ix)) .GT. noutstr ) THEN
1015        noerr = .FALSE.  ! would overwrite
1016      ELSE IF( dexes(ix) .EQ. dexes(ix+1) ) THEN
1017        noerr = .FALSE.  ! not found
1018      ELSE
1019        outstr = instr(dexes(ix):(dexes(ix+1)-2))
1020        noerr = noerr .AND. .TRUE.
1021      ENDIF
1022    END SUBROUTINE get_fieldstr
1023
1024    SUBROUTINE change_to_lower_case(instr,outstr)
1025      CHARACTER*(*) ,INTENT(IN)  :: instr
1026      CHARACTER*(*) ,INTENT(OUT) :: outstr
1027 !Local
1028      CHARACTER*1                :: c
1029      INTEGER       ,PARAMETER   :: upper_to_lower =IACHAR('a')-IACHAR('A')
1030      INTEGER                    :: i,n,n1
1031 !
1032      outstr = ' '
1033      N = len(instr)
1034      N1 = len(outstr)
1035      N = MIN(N,N1)
1036      outstr(1:N) = instr(1:N)
1037      DO i=1,N
1038        c = instr(i:i)
1039        if('A'<=c .and. c <='Z') outstr(i:i)=achar(iachar(c)+upper_to_lower)
1040      ENDDO
1041      RETURN
1042    END SUBROUTINE change_to_lower_case
1043
1044 !
1045    SUBROUTINE modify_io_masks1 ( grid , id )
1046       IMPLICIT NONE
1047 #include "streams.h"
1048       INTEGER              , INTENT(IN  )  :: id
1049       TYPE(domain), POINTER                :: grid
1050       ! Local
1051       TYPE(fieldlist), POINTER :: p, q
1052       INTEGER, PARAMETER :: read_unit = 10
1053       LOGICAL, EXTERNAL  :: wrf_dm_on_monitor
1054       CHARACTER*8000     :: inln, t1, fieldlst
1055       CHARACTER*256      :: fname, mess, dname, lookee
1056       CHARACTER*1        :: op, strmtyp
1057       CHARACTER*3        :: strmid
1058       CHARACTER*10       :: strmtyp_name
1059       INTEGER            :: io_status
1060       INTEGER            :: strmtyp_int, count_em
1061       INTEGER            :: lineno, fieldno, istrm, retval, itrace
1062       LOGICAL            :: keepgoing, noerr, gavewarning, ignorewarning, found
1063       LOGICAL, SAVE      :: you_warned_me = .FALSE.
1064       LOGICAL, SAVE      :: you_warned_me2(max_hst_mods,max_domains) = .FALSE.
1065
1066       gavewarning = .FALSE.
1067
1068       CALL nl_get_iofields_filename( id, fname )
1069
1070       IF ( grid%is_intermediate ) RETURN                ! short circuit
1071       IF ( TRIM(fname) .EQ. "NONE_SPECIFIED" ) RETURN   ! short circuit
1072
1073       IF ( wrf_dm_on_monitor() ) THEN
1074         OPEN ( UNIT   = read_unit    ,      &
1075                FILE   = TRIM(fname)      ,      &
1076                FORM   = "FORMATTED"      ,      &
1077                STATUS = "OLD"            ,      &
1078                IOSTAT = io_status         )
1079         IF ( io_status .EQ. 0 ) THEN   ! only on success
1080           keepgoing = .TRUE.
1081           lineno = 0
1082           count_em = 0    ! Count the total number of fields
1083           DO WHILE ( keepgoing )
1084             READ(UNIT=read_unit,FMT='(A)',IOSTAT=io_status) inln
1085             keepgoing = (io_status .EQ. 0) .AND. (LEN(TRIM(inln)) .GT. 0)
1086             IF ( keepgoing ) THEN
1087               lineno = lineno + 1
1088               IF ( .NOT. LEN(TRIM(inln)) .LT. LEN(inln) ) THEN
1089                 WRITE(mess,*)'W A R N I N G : Line ',lineno,' of ',TRIM(fname),' is too long. Limit is ',LEN(inln),' characters.'
1090                 gavewarning = .TRUE.
1091               ENDIF
1092               IF ( INDEX(inln,'#') .EQ. 0 ) THEN   ! skip comments, which is a # anywhere on line
1093                 IF ( keepgoing ) THEN
1094                   noerr = .TRUE.
1095                   CALL get_fieldstr(1,':',inln,op,1,noerr)          ! + is add, - is remove
1096                   IF ( TRIM(op) .NE. '+' .AND. TRIM(op) .NE. '-' ) THEN
1097                     WRITE(mess,*)'W A R N I N G : unknown operation ',TRIM(op),' (should be + or -). Line ',lineno
1098                     gavewarning = .TRUE.
1099                   ENDIF
1100                   CALL get_fieldstr(2,':',inln,t1,1,noerr)          ! i is input, h is history
1101                   CALL change_to_lower_case(t1,strmtyp)
1102
1103                   SELECT CASE (TRIM(strmtyp))
1104                   CASE ('h')
1105                      strmtyp_name = 'history'
1106                      strmtyp_int  = first_history
1107                   CASE ('i')
1108                      strmtyp_name = 'input'
1109                      strmtyp_int  = first_input
1110                   CASE DEFAULT
1111                      WRITE(mess,*)'W A R N I N G : unknown stream type ',TRIM(strmtyp),'. Line ',lineno
1112                      gavewarning = .TRUE.
1113                   END SELECT
1114
1115                   CALL get_fieldstr(3,':',inln,strmid,3,noerr)      ! number of stream (main input and hist are 0)
1116                   READ(strmid,'(I3)') istrm
1117                   IF ( istrm .LT. 0 .OR. istrm .GT. last_history ) THEN
1118                     WRITE(mess,*)'W A R N I N G : invalid stream id ',istrm,' (should be 0 <= id <= ',last_history,'). Line ',lineno
1119                     gavewarning = .TRUE.
1120                   ENDIF
1121                   CALL get_fieldstr(4,':',inln,fieldlst,8000,noerr) ! get list of fields
1122                   IF ( noerr ) THEN
1123                     fieldno = 1
1124                     CALL get_fieldstr(fieldno,',',fieldlst,t1,8000,noerr)
1125                     CALL change_to_lower_case(t1,lookee)
1126                     DO WHILE ( noerr )    ! linear search, blargh...
1127                       p => grid%head_statevars%next
1128                       found = .FALSE.
1129                       count_em = count_em + 1
1130                       DO WHILE ( ASSOCIATED( p ) )
1131
1132                         IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
1133
1134                           DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
1135                             CALL change_to_lower_case( p%dname_table( grid%id, itrace ) , dname )
1136
1137                             IF ( TRIM(dname) .EQ. TRIM(lookee) ) &
1138                             CALL warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
1139                                                       strmtyp_name, dname, fname, lookee,      &
1140                                                       p%streams_table(grid%id,itrace)%stream,  &
1141                                                       mess, found, you_warned_me2)
1142                           ENDDO
1143                         ELSE
1144                           IF ( p%Ntl .GT. 0 ) THEN
1145                             CALL change_to_lower_case(p%DataName(1:LEN(TRIM(p%DataName))-2),dname)
1146                           ELSE
1147                             CALL change_to_lower_case(p%DataName,dname)
1148                           ENDIF
1149
1150                           IF ( TRIM(dname) .EQ. TRIM(lookee) ) &
1151                           CALL warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
1152                                                     strmtyp_name, dname, fname, lookee,      &
1153                                                     p%streams, mess, found, you_warned_me2)
1154                         ENDIF
1155                         p => p%next
1156                       ENDDO
1157                       IF ( .NOT. found ) THEN
1158 #if ( WRFPLUS != 1 )
1159                         WRITE(mess,*)'W A R N I N G : Unable to modify mask for ',TRIM(lookee),&
1160                                      '.  Variable not found. File: ',TRIM(fname),' at line ',lineno
1161                         CALL wrf_message(mess)
1162 #endif
1163                         gavewarning = .TRUE.
1164                       ENDIF
1165                       fieldno = fieldno + 1
1166                       CALL get_fieldstr(fieldno,',',fieldlst,t1,256,noerr)
1167                       CALL change_to_lower_case(t1,lookee)
1168                     ENDDO
1169                   ELSE
1170                     WRITE(mess,*)'W A R N I N G : Problem reading ',TRIM(fname),' at line ',lineno
1171                     CALL wrf_message(mess)
1172                     gavewarning = .TRUE.
1173                   ENDIF
1174                 ENDIF  ! keepgoing
1175               ENDIF    ! skip comments
1176             ENDIF      ! keepgoing
1177           ENDDO
1178         ELSE
1179           WRITE(mess,*)'W A R N I N G : Problem opening ',TRIM(fname)
1180           CALL wrf_message(mess)
1181           gavewarning = .TRUE.
1182         ENDIF
1183         CLOSE( read_unit )
1184         IF ( gavewarning ) THEN
1185           CALL nl_get_ignore_iofields_warning(1,ignorewarning)
1186           IF ( .NOT. ignorewarning ) THEN
1187             CALL wrf_message(mess)
1188             WRITE(mess,*)'modify_io_masks: problems reading ',TRIM(fname)
1189             CALL wrf_message(mess)
1190             CALL wrf_error_fatal('Set ignore_iofields_warn to true in namelist to ignore')
1191           ELSE
1192             IF ( .NOT. you_warned_me ) THEN
1193               if ( .NOT. you_warned_me2(count_em,id) ) CALL wrf_message(mess)  ! Don't repeat the W A R N I N G message
1194               WRITE(mess,*)'Ignoring problems reading ',TRIM(fname)
1195               CALL wrf_message(mess)
1196               CALL wrf_message('Continuing.  To make this a fatal error, set ignore_iofields_warn to false in namelist' )
1197               CALL wrf_message(' ')
1198               you_warned_me = .TRUE.
1199             ENDIF
1200           ENDIF
1201         ENDIF
1202       ENDIF  ! wrf_dm_on_monitor
1203
1204 #ifdef DM_PARALLEL
1205 ! broadcast the new masks to the other tasks
1206       p => grid%head_statevars%next
1207       DO WHILE ( ASSOCIATED( p ) )
1208         IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
1209
1210           DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
1211             CALL wrf_dm_bcast_integer( p%streams_table(grid%id,itrace)%stream, IO_MASK_SIZE )
1212           ENDDO
1213
1214         ELSE
1215           CALL wrf_dm_bcast_integer( p%streams, IO_MASK_SIZE )
1216         ENDIF
1217         p => p%next
1218       ENDDO
1219 #endif
1220
1221    END SUBROUTINE modify_io_masks1
1222
1223    SUBROUTINE warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
1224                                    strmtyp_name, dname, fname, lookee,      &
1225                                    p_stream, mess, found, you_warned_me2)
1226
1227       IMPLICIT NONE
1228
1229 ! See if a field that is requested to be added to or removed from the I/O stream
1230 !    is already present or absent
1231 ! If the requested action has already been done, write a warning message
1232 ! If not, satisfy the request
1233
1234      INTEGER,       INTENT(IN )   :: id, istrm, lineno, strmtyp_int
1235      INTEGER,       INTENT(IN )   :: p_stream(*), count_em
1236      CHARACTER*1,   INTENT(IN )   :: op
1237      CHARACTER*10,  INTENT(IN )   :: strmtyp_name
1238      CHARACTER*256, INTENT(IN )   :: dname, fname, lookee
1239      CHARACTER*256, INTENT(OUT)   :: mess
1240      LOGICAL,       INTENT(OUT)   :: found
1241      LOGICAL,       INTENT(INOUT) :: you_warned_me2(max_hst_mods,max_domains)
1242    ! Local
1243      INTEGER                      :: retval
1244
1245      found = .TRUE.
1246      IF      ( TRIM(op) .EQ. '+' ) THEN
1247        CALL get_mask( p_stream, strmtyp_int + istrm - 1, retval )
1248        IF ( retval .NE. 0 ) THEN
1249          WRITE(mess,*) 'Domain ',id, ' W A R N I N G : Variable ',TRIM(lookee),' already on ', &
1250                        TRIM(strmtyp_name), ' stream ',istrm, '.  File: ', TRIM(fname),' at line ',lineno
1251        ELSE
1252          WRITE(mess,*) 'Domain ', id, ' Setting ', TRIM(strmtyp_name), ' stream ',istrm,' for ', &
1253                                   TRIM(DNAME)  ; CALL wrf_debug(1,mess)
1254          CALL set_mask( p_stream, strmtyp_int + istrm - 1 )
1255        ENDIF
1256      ELSE IF ( TRIM(op) .EQ. '-' ) THEN
1257        CALL get_mask( p_stream, strmtyp_int + istrm - 1, retval )
1258        IF ( retval .EQ. 0 ) THEN
1259          WRITE(mess,*) 'Domain ',id, ' W A R N I N G : Variable ',TRIM(lookee),' already off ', &
1260                        TRIM(strmtyp_name), ' stream ',istrm, '. File: ',TRIM(fname),' at line ',lineno
1261        ELSE
1262          WRITE(mess,*) 'Domain ', id, ' Resetting ', TRIM(strmtyp_name), ' stream ',istrm,' for ', &
1263                                     TRIM(DNAME)  ; CALL wrf_debug(1,mess)
1264          CALL reset_mask( p_stream, strmtyp_int + istrm - 1)
1265        ENDIF
1266      ENDIF
1267      IF ( count_em > max_hst_mods ) THEN
1268 #if ( DA_CORE != 1 )
1269        WRITE(mess,*)'ERROR module_domain:  Array size for you_warned_me2 is fixed at ',max_hst_mods
1270        CALL wrf_message(mess)
1271        CALL wrf_error_fatal('Did you really type > max_hst_mods fields into ', TRIM(fname) ,' ?')
1272 #endif
1273      ELSE
1274        IF ( .NOT. you_warned_me2(count_em,id) ) THEN
1275          CALL wrf_message(mess)     ! Write warning message once for each field
1276          you_warned_me2(count_em,id) = .TRUE.
1277        ENDIF
1278      ENDIF
1279
1280    END SUBROUTINE warn_me_or_set_mask
1281
1282 !  This routine ALLOCATEs the required space for the meteorological fields
1283 !  for a specific domain.  The fields are simply ALLOCATEd as an -1.  They
1284 !  are referenced as wind, temperature, moisture, etc. in routines that are
1285 !  below this top-level of data allocation and management (in the solve routine
1286 !  and below).
1287
1288    SUBROUTINE alloc_space_field ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , okay_to_alloc_in,  &
1289                                   sd31, ed31, sd32, ed32, sd33, ed33, &
1290                                   sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1291                                   sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1292                                   sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1293                                   sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1294                                   sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1295                                   sm31y, em31y, sm32y, em32y, sm33y, em33y )
1296
1297
1298       IMPLICIT NONE
1299
1300 #include "allocs.inc"
1301
1302       !  Input data.
1303
1304       TYPE(domain)               , POINTER          :: grid
1305       INTEGER , INTENT(IN)            :: id
1306       INTEGER , INTENT(IN)            :: setinitval_in   ! 3 = everything, 1 = arrays only, 0 = none
1307       INTEGER , INTENT(IN)            :: sd31, ed31, sd32, ed32, sd33, ed33
1308       INTEGER , INTENT(IN)            :: sm31, em31, sm32, em32, sm33, em33
1309       INTEGER , INTENT(IN)            :: sp31, ep31, sp32, ep32, sp33, ep33
1310       INTEGER , INTENT(IN)            :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x
1311       INTEGER , INTENT(IN)            :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y
1312       INTEGER , INTENT(IN)            :: sm31x, em31x, sm32x, em32x, sm33x, em33x
1313       INTEGER , INTENT(IN)            :: sm31y, em31y, sm32y, em32y, sm33y, em33y
1314
1315       ! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.
1316       ! e.g. to set both 1st and second time level, use 3
1317       !      to set only 1st                        use 1
1318       !      to set only 2st                        use 2
1319       INTEGER , INTENT(IN)            :: tl_in
1320
1321       ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated
1322       ! false otherwise (all allocated, modulo tl above)
1323       LOGICAL , INTENT(IN)            :: inter_domain_in, okay_to_alloc_in
1324
1325       ! Local
1326       INTEGER(KIND=8)  num_bytes_allocated
1327       INTEGER  idum1, idum2
1328
1329 #if (EM_CORE == 1)
1330       IF ( grid%id .EQ. 1 ) CALL wrf_message ( &
1331           'DYNAMICS OPTION: Eulerian Mass Coordinate ')
1332 #endif
1333
1334       CALL set_scalar_indices_from_config( id , idum1 , idum2 )
1335
1336       num_bytes_allocated = 0
1337
1338       ! Now use auto-split routines to allocate
1339 #include "allocs_calls.inc"
1340
1341       IF ( .NOT. grid%have_displayed_alloc_stats ) THEN
1342         ! we do not want to see this message more than once, as can happen with the allocation and
1343         ! deallocation of intermediate domains used in nesting.
1344         WRITE(wrf_err_message,*)&
1345             'alloc_space_field: domain ',id,', ',num_bytes_allocated,' bytes allocated'
1346         CALL  wrf_debug( 0, wrf_err_message )
1347         grid%have_displayed_alloc_stats = .TRUE.
1348       ENDIF
1349
1350
1351       grid%alloced_sd31=sd31
1352       grid%alloced_ed31=ed31
1353       grid%alloced_sd32=sd32
1354       grid%alloced_ed32=ed32
1355       grid%alloced_sd33=sd33
1356       grid%alloced_ed33=ed33
1357       grid%alloced_sm31=sm31
1358       grid%alloced_em31=em31
1359       grid%alloced_sm32=sm32
1360       grid%alloced_em32=em32
1361       grid%alloced_sm33=sm33
1362       grid%alloced_em33=em33
1363       grid%alloced_sm31x=sm31x
1364       grid%alloced_em31x=em31x
1365       grid%alloced_sm32x=sm32x
1366       grid%alloced_em32x=em32x
1367       grid%alloced_sm33x=sm33x
1368       grid%alloced_em33x=em33x
1369       grid%alloced_sm31y=sm31y
1370       grid%alloced_em31y=em31y
1371       grid%alloced_sm32y=sm32y
1372       grid%alloced_em32y=em32y
1373       grid%alloced_sm33y=sm33y
1374       grid%alloced_em33y=em33y
1375
1376       grid%allocated=.TRUE.
1377
1378    END SUBROUTINE alloc_space_field
1379
1380    ! Ensure_space_field allocates a grid's arrays if they are not yet
1381    ! allocated.  If they were already allocated, then it deallocates and
1382    ! reallocates them if they were allocated with different dimensions.
1383    ! If they were already allocated with the requested dimensions, then
1384    ! ensure_space_field does nothing.
1385
1386    SUBROUTINE ensure_space_field ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , okay_to_alloc_in,  &
1387                                   sd31, ed31, sd32, ed32, sd33, ed33, &
1388                                   sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1389                                   sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1390                                   sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1391                                   sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1392                                   sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1393                                   sm31y, em31y, sm32y, em32y, sm33y, em33y )
1394
1395       IMPLICIT NONE
1396
1397       !  Input data.
1398
1399       TYPE(domain)               , POINTER          :: grid
1400       INTEGER , INTENT(IN)            :: id
1401       INTEGER , INTENT(IN)            :: setinitval_in   ! 3 = everything, 1 = arrays only, 0 = none
1402       INTEGER , INTENT(IN)            :: sd31, ed31, sd32, ed32, sd33, ed33
1403       INTEGER , INTENT(IN)            :: sm31, em31, sm32, em32, sm33, em33
1404       INTEGER , INTENT(IN)            :: sp31, ep31, sp32, ep32, sp33, ep33
1405       INTEGER , INTENT(IN)            :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x
1406       INTEGER , INTENT(IN)            :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y
1407       INTEGER , INTENT(IN)            :: sm31x, em31x, sm32x, em32x, sm33x, em33x
1408       INTEGER , INTENT(IN)            :: sm31y, em31y, sm32y, em32y, sm33y, em33y
1409
1410       ! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.
1411       ! e.g. to set both 1st and second time level, use 3
1412       !      to set only 1st                        use 1
1413       !      to set only 2st                        use 2
1414       INTEGER , INTENT(IN)            :: tl_in
1415
1416       ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated
1417       ! false otherwise (all allocated, modulo tl above)
1418       LOGICAL , INTENT(IN)            :: inter_domain_in, okay_to_alloc_in
1419       LOGICAL                         :: size_changed
1420
1421       size_changed=         .not. ( &
1422          grid%alloced_sd31 .eq. sd31 .and. grid%alloced_ed31 .eq. ed31 .and. &
1423          grid%alloced_sd32 .eq. sd32 .and. grid%alloced_ed32 .eq. ed32 .and. &
1424          grid%alloced_sd33 .eq. sd33 .and. grid%alloced_ed33 .eq. ed33 .and. &
1425          grid%alloced_sm31 .eq. sm31 .and. grid%alloced_em31 .eq. em31 .and. &
1426          grid%alloced_sm32 .eq. sm32 .and. grid%alloced_em32 .eq. em32 .and. &
1427          grid%alloced_sm33 .eq. sm33 .and. grid%alloced_em33 .eq. em33 .and. &
1428          grid%alloced_sm31x .eq. sm31x .and. grid%alloced_em31x .eq. em31x .and. &
1429          grid%alloced_sm32x .eq. sm32x .and. grid%alloced_em32x .eq. em32x .and. &
1430          grid%alloced_sm33x .eq. sm33x .and. grid%alloced_em33x .eq. em33x .and. &
1431          grid%alloced_sm31y .eq. sm31y .and. grid%alloced_em31y .eq. em31y .and. &
1432          grid%alloced_sm32y .eq. sm32y .and. grid%alloced_em32y .eq. em32y .and. &
1433          grid%alloced_sm33y .eq. sm33y .and. grid%alloced_em33y .eq. em33y &
1434       )
1435       if(.not. grid%allocated .or. size_changed) then
1436          if(.not. grid%allocated) then
1437             call wrf_debug(1,'ensure_space_field: calling alloc_space_field because a grid was not allocated.')
1438          else
1439             if(size_changed) &
1440                  call wrf_debug(1,'ensure_space_field: deallocating and reallocating a grid because grid size changed.')
1441          end if
1442          if(grid%allocated) &
1443               call dealloc_space_field( grid )
1444          call alloc_space_field ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , okay_to_alloc_in,  &
1445                                   sd31, ed31, sd32, ed32, sd33, ed33, &
1446                                   sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1447                                   sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1448                                   sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1449                                   sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1450                                   sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1451                                   sm31y, em31y, sm32y, em32y, sm33y, em33y )
1452       end if
1453
1454    END SUBROUTINE ensure_space_field
1455
1456 !  This routine is used to DEALLOCATE space for a single domain and remove
1457 !  it from the linked list.  First the pointers in the linked list are fixed
1458 !  (so the one in the middle can be removed).  Then the domain itself is
1459 !  DEALLOCATEd via a call to domain_destroy().
1460
1461    SUBROUTINE dealloc_space_domain ( id )
1462
1463       IMPLICIT NONE
1464
1465       !  Input data.
1466
1467       INTEGER , INTENT(IN)            :: id
1468
1469       !  Local data.
1470
1471       TYPE(domain) , POINTER          :: grid
1472       LOGICAL                         :: found
1473
1474       !  Initializations required to start the routine.
1475
1476       grid => head_grid
1477       old_grid => head_grid
1478       found = .FALSE.
1479
1480       !  The identity of the domain to delete is based upon the "id".
1481       !  We search all of the possible grids.  It is required to find a domain
1482       !  otherwise it is a fatal error.
1483
1484       find_grid : DO WHILE ( ASSOCIATED(grid) )
1485          IF ( grid%id == id ) THEN
1486             found = .TRUE.
1487             old_grid%next => grid%next
1488             CALL domain_destroy( grid )
1489             EXIT find_grid
1490          END IF
1491          old_grid => grid
1492          grid     => grid%next
1493       END DO find_grid
1494
1495       IF ( .NOT. found ) THEN
1496          WRITE ( wrf_err_message , * ) 'module_domain: ', &
1497            'dealloc_space_domain: Could not de-allocate grid id ',id
1498          CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1499       END IF
1500
1501    END SUBROUTINE dealloc_space_domain
1502
1503
1504
1505 !  This routine is used to DEALLOCATE space for a single domain type.
1506 !  First, the field data are all removed through a CALL to the
1507 !  dealloc_space_field routine.  Then the pointer to the domain
1508 !  itself is DEALLOCATEd.
1509
1510    SUBROUTINE domain_destroy ( grid )
1511
1512       IMPLICIT NONE
1513
1514       !  Input data.
1515
1516       TYPE(domain) , POINTER          :: grid
1517
1518       CALL dealloc_space_field ( grid )
1519       CALL dealloc_linked_lists( grid )
1520       DEALLOCATE( grid%parents )
1521       DEALLOCATE( grid%nests )
1522       ! clean up time manager bits
1523       CALL domain_clock_destroy( grid )
1524       CALL domain_alarms_destroy( grid )
1525       IF ( ASSOCIATED( grid%i_start ) ) THEN
1526         DEALLOCATE( grid%i_start )
1527       ENDIF
1528       IF ( ASSOCIATED( grid%i_end ) ) THEN
1529         DEALLOCATE( grid%i_end )
1530       ENDIF
1531       IF ( ASSOCIATED( grid%j_start ) ) THEN
1532         DEALLOCATE( grid%j_start )
1533       ENDIF
1534       IF ( ASSOCIATED( grid%j_end ) ) THEN
1535         DEALLOCATE( grid%j_end )
1536       ENDIF
1537       IF ( ASSOCIATED( grid%itsloc ) ) THEN
1538         DEALLOCATE( grid%itsloc )
1539       ENDIF
1540       IF ( ASSOCIATED( grid%jtsloc ) ) THEN
1541         DEALLOCATE( grid%jtsloc )
1542       ENDIF
1543       IF ( ASSOCIATED( grid%id_tsloc ) ) THEN
1544         DEALLOCATE( grid%id_tsloc )
1545       ENDIF
1546       IF ( ASSOCIATED( grid%lattsloc ) ) THEN
1547         DEALLOCATE( grid%lattsloc )
1548       ENDIF
1549       IF ( ASSOCIATED( grid%lontsloc ) ) THEN
1550         DEALLOCATE( grid%lontsloc )
1551       ENDIF
1552       IF ( ASSOCIATED( grid%nametsloc ) ) THEN
1553         DEALLOCATE( grid%nametsloc )
1554       ENDIF
1555       IF ( ASSOCIATED( grid%desctsloc ) ) THEN
1556         DEALLOCATE( grid%desctsloc )
1557       ENDIF
1558       IF ( ASSOCIATED( grid%ts_filename ) ) THEN
1559         DEALLOCATE( grid%ts_filename )
1560       ENDIF
1561 #if (EM_CORE == 1)
1562       IF ( ASSOCIATED( grid%track_time_in ) ) THEN
1563         DEALLOCATE( grid%track_time_in )
1564       ENDIF
1565
1566       IF ( ASSOCIATED( grid%track_lat_in ) ) THEN
1567         DEALLOCATE( grid%track_lat_in )
1568       ENDIF
1569
1570       IF ( ASSOCIATED( grid%track_lon_in ) ) THEN
1571         DEALLOCATE( grid%track_lon_in )
1572       ENDIF
1573
1574       IF ( ASSOCIATED( grid%track_i ) ) THEN
1575         DEALLOCATE( grid%track_i )
1576       ENDIF
1577
1578       IF ( ASSOCIATED( grid%track_j ) ) THEN
1579         DEALLOCATE( grid%track_j )
1580       ENDIF
1581
1582       IF ( ASSOCIATED( grid%track_time_domain ) ) THEN
1583         DEALLOCATE( grid%track_time_domain )
1584       ENDIF
1585
1586       IF ( ASSOCIATED( grid%track_lat_domain ) ) THEN
1587         DEALLOCATE( grid%track_lat_domain )
1588       ENDIF
1589
1590       IF ( ASSOCIATED( grid%track_lon_domain ) ) THEN
1591         DEALLOCATE( grid%track_lon_domain )
1592       ENDIF
1593 #endif
1594       DEALLOCATE( grid )
1595       NULLIFY( grid )
1596
1597    END SUBROUTINE domain_destroy
1598
1599    SUBROUTINE dealloc_linked_lists ( grid )
1600       IMPLICIT NONE
1601       TYPE(domain), POINTER :: grid
1602       TYPE(fieldlist), POINTER :: p, q
1603       p => grid%head_statevars
1604       DO WHILE ( ASSOCIATED( p ) )
1605         if (p%varname.eq."chem_ic")  exit
1606          q => p ; p => p%next ; DEALLOCATE(q)
1607       ENDDO
1608       NULLIFY(grid%head_statevars) ; NULLIFY( grid%tail_statevars)
1609 #if (DA_CORE != 1)
1610       IF ( .NOT. grid%is_intermediate ) THEN
1611         ALLOCATE( grid%head_statevars )
1612         NULLIFY( grid%head_statevars%next)
1613         grid%tail_statevars => grid%head_statevars
1614       ENDIF
1615 #endif
1616    END SUBROUTINE dealloc_linked_lists
1617
1618    RECURSIVE SUBROUTINE show_nest_subtree ( grid )
1619       TYPE(domain), POINTER :: grid
1620       INTEGER myid
1621       INTEGER kid
1622       IF ( .NOT. ASSOCIATED( grid ) ) RETURN
1623       myid = grid%id
1624       DO kid = 1, max_nests
1625         IF ( ASSOCIATED( grid%nests(kid)%ptr ) ) THEN
1626           IF ( grid%nests(kid)%ptr%id .EQ. myid ) THEN
1627             CALL wrf_error_fatal( 'show_nest_subtree: nest hierarchy corrupted' )
1628           ENDIF
1629           CALL show_nest_subtree( grid%nests(kid)%ptr )
1630         ENDIF
1631       ENDDO
1632    END SUBROUTINE show_nest_subtree
1633
1634
1635 !
1636
1637 !  This routine DEALLOCATEs each gridded field for this domain.  For each type of
1638 !  different array (1d, 2d, 3d, etc.), the space for each pointer is DEALLOCATEd
1639 !  for every -1 (i.e., each different meteorological field).
1640
1641    SUBROUTINE dealloc_space_field ( grid )
1642
1643       IMPLICIT NONE
1644
1645       !  Input data.
1646
1647       TYPE(domain)              , POINTER :: grid
1648
1649 # include "deallocs.inc"
1650
1651    END SUBROUTINE dealloc_space_field
1652
1653 !
1654 !
1655    RECURSIVE SUBROUTINE find_grid_by_id ( id, in_grid, result_grid )
1656       IMPLICIT NONE
1657       INTEGER, INTENT(IN) :: id
1658       TYPE(domain), POINTER     :: in_grid
1659       TYPE(domain), POINTER     :: result_grid
1660 ! <DESCRIPTION>
1661 ! This is a recursive subroutine that traverses the domain hierarchy rooted
1662 ! at the input argument <em>in_grid</em>, a pointer to TYPE(domain), and returns
1663 ! a pointer to the domain matching the integer argument <em>id</em> if it exists.
1664 !
1665 ! </DESCRIPTION>
1666       TYPE(domain), POINTER     :: grid_ptr
1667       INTEGER                   :: kid
1668       LOGICAL                   :: found
1669       found = .FALSE.
1670       NULLIFY(result_grid)
1671       IF ( ASSOCIATED( in_grid ) ) THEN
1672         IF ( in_grid%id .EQ. id ) THEN
1673            result_grid => in_grid
1674         ELSE
1675            grid_ptr => in_grid
1676            DO WHILE ( ASSOCIATED( grid_ptr ) .AND. .NOT. found )
1677               DO kid = 1, max_nests
1678                  IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) .AND. .NOT. found ) THEN
1679                     CALL find_grid_by_id ( id, grid_ptr%nests(kid)%ptr, result_grid )
1680                     IF ( ASSOCIATED( result_grid ) ) THEN
1681                       IF ( result_grid%id .EQ. id ) found = .TRUE.
1682                     ENDIF
1683                  ENDIF
1684               ENDDO
1685               IF ( .NOT. found ) grid_ptr => grid_ptr%sibling
1686            ENDDO
1687         ENDIF
1688       ENDIF
1689       RETURN
1690    END SUBROUTINE find_grid_by_id
1691
1692
1693    FUNCTION first_loc_integer ( array , search ) RESULT ( loc )
1694
1695       IMPLICIT NONE
1696
1697       !  Input data.
1698
1699       INTEGER , INTENT(IN) , DIMENSION(:) :: array
1700       INTEGER , INTENT(IN)                :: search
1701
1702       !  Output data.
1703
1704       INTEGER                             :: loc
1705
1706 !<DESCRIPTION>
1707 !  This routine is used to find a specific domain identifier in an array
1708 !  of domain identifiers.
1709 !
1710 !</DESCRIPTION>
1711
1712       !  Local data.
1713
1714       INTEGER :: loop
1715
1716       loc = -1
1717       find : DO loop = 1 , SIZE(array)
1718          IF ( search == array(loop) ) THEN
1719             loc = loop
1720             EXIT find
1721          END IF
1722       END DO find
1723
1724    END FUNCTION first_loc_integer
1725 !
1726    SUBROUTINE init_module_domain
1727    END SUBROUTINE init_module_domain
1728
1729
1730 ! <DESCRIPTION>
1731 !
1732 ! The following routines named domain_*() are convenience routines that
1733 ! eliminate many duplicated bits of code.  They provide shortcuts for the
1734 ! most common operations on the domain_clock field of TYPE(domain).
1735 !
1736 ! </DESCRIPTION>
1737
1738       FUNCTION domain_get_current_time ( grid ) RESULT ( current_time )
1739         IMPLICIT NONE
1740 ! <DESCRIPTION>
1741 ! This convenience function returns the current time for domain grid.
1742 !
1743 ! </DESCRIPTION>
1744         TYPE(domain), INTENT(IN) :: grid
1745         ! result
1746         TYPE(WRFU_Time) :: current_time
1747         ! locals
1748         INTEGER :: rc
1749         CALL WRFU_ClockGet( grid%domain_clock, CurrTime=current_time, &
1750                             rc=rc )
1751         IF ( rc /= WRFU_SUCCESS ) THEN
1752           CALL wrf_error_fatal ( &
1753             'domain_get_current_time:  WRFU_ClockGet failed' )
1754         ENDIF
1755       END FUNCTION domain_get_current_time
1756
1757
1758       FUNCTION domain_get_start_time ( grid ) RESULT ( start_time )
1759         IMPLICIT NONE
1760 ! <DESCRIPTION>
1761 ! This convenience function returns the start time for domain grid.
1762 !
1763 ! </DESCRIPTION>
1764         TYPE(domain), INTENT(IN) :: grid
1765         ! result
1766         TYPE(WRFU_Time) :: start_time
1767         ! locals
1768         INTEGER :: rc
1769         CALL WRFU_ClockGet( grid%domain_clock, StartTime=start_time, &
1770                             rc=rc )
1771         IF ( rc /= WRFU_SUCCESS ) THEN
1772           CALL wrf_error_fatal ( &
1773             'domain_get_start_time:  WRFU_ClockGet failed' )
1774         ENDIF
1775       END FUNCTION domain_get_start_time
1776
1777
1778       FUNCTION domain_get_stop_time ( grid ) RESULT ( stop_time )
1779         IMPLICIT NONE
1780 ! <DESCRIPTION>
1781 ! This convenience function returns the stop time for domain grid.
1782 !
1783 ! </DESCRIPTION>
1784         TYPE(domain), INTENT(IN) :: grid
1785         ! result
1786         TYPE(WRFU_Time) :: stop_time
1787         ! locals
1788         INTEGER :: rc
1789         CALL WRFU_ClockGet( grid%domain_clock, StopTime=stop_time, &
1790                             rc=rc )
1791         IF ( rc /= WRFU_SUCCESS ) THEN
1792           CALL wrf_error_fatal ( &
1793             'domain_get_stop_time:  WRFU_ClockGet failed' )
1794         ENDIF
1795       END FUNCTION domain_get_stop_time
1796
1797
1798       FUNCTION domain_get_time_step ( grid ) RESULT ( time_step )
1799         IMPLICIT NONE
1800 ! <DESCRIPTION>
1801 ! This convenience function returns the time step for domain grid.
1802 !
1803 ! </DESCRIPTION>
1804         TYPE(domain), INTENT(IN) :: grid
1805         ! result
1806         TYPE(WRFU_TimeInterval) :: time_step
1807         ! locals
1808         INTEGER :: rc
1809         CALL WRFU_ClockGet( grid%domain_clock, timeStep=time_step, &
1810                             rc=rc )
1811         IF ( rc /= WRFU_SUCCESS ) THEN
1812           CALL wrf_error_fatal ( &
1813             'domain_get_time_step:  WRFU_ClockGet failed' )
1814         ENDIF
1815       END FUNCTION domain_get_time_step
1816
1817
1818       FUNCTION domain_get_advanceCount ( grid ) RESULT ( advanceCount )
1819         IMPLICIT NONE
1820 ! <DESCRIPTION>
1821 ! This convenience function returns the time step for domain grid.
1822 ! Also converts from INTEGER(WRFU_KIND_I8) to INTEGER.
1823 !
1824 ! </DESCRIPTION>
1825         TYPE(domain), INTENT(IN) :: grid
1826         ! result
1827         INTEGER :: advanceCount
1828         ! locals
1829         INTEGER(WRFU_KIND_I8) :: advanceCountLcl
1830         INTEGER :: rc
1831         CALL WRFU_ClockGet( grid%domain_clock, &
1832                             advanceCount=advanceCountLcl, &
1833                             rc=rc )
1834         IF ( rc /= WRFU_SUCCESS ) THEN
1835           CALL wrf_error_fatal ( &
1836             'domain_get_advanceCount:  WRFU_ClockGet failed' )
1837         ENDIF
1838         advanceCount = advanceCountLcl
1839       END FUNCTION domain_get_advanceCount
1840
1841
1842       SUBROUTINE domain_alarms_destroy ( grid )
1843         IMPLICIT NONE
1844 ! <DESCRIPTION>
1845 ! This convenience routine destroys and deallocates all alarms associated
1846 ! with grid.
1847 !
1848 ! </DESCRIPTION>
1849         TYPE(domain), INTENT(INOUT) :: grid
1850         !  Local data.
1851         INTEGER                     :: alarmid
1852
1853         IF ( ASSOCIATED( grid%alarms ) .AND. &
1854              ASSOCIATED( grid%alarms_created ) ) THEN
1855           DO alarmid = 1, MAX_WRF_ALARMS
1856             IF ( grid%alarms_created( alarmid ) ) THEN
1857               CALL WRFU_AlarmDestroy( grid%alarms( alarmid ) )
1858               grid%alarms_created( alarmid ) = .FALSE.
1859             ENDIF
1860           ENDDO
1861           DEALLOCATE( grid%alarms )
1862           NULLIFY( grid%alarms )
1863           DEALLOCATE( grid%alarms_created )
1864           NULLIFY( grid%alarms_created )
1865         ENDIF
1866       END SUBROUTINE domain_alarms_destroy
1867
1868
1869       SUBROUTINE domain_clock_destroy ( grid )
1870         IMPLICIT NONE
1871 ! <DESCRIPTION>
1872 ! This convenience routine destroys and deallocates the domain clock.
1873 !
1874 ! </DESCRIPTION>
1875         TYPE(domain), INTENT(INOUT) :: grid
1876         IF ( ASSOCIATED( grid%domain_clock ) ) THEN
1877           IF ( grid%domain_clock_created ) THEN
1878             CALL WRFU_ClockDestroy( grid%domain_clock )
1879             grid%domain_clock_created = .FALSE.
1880           ENDIF
1881           DEALLOCATE( grid%domain_clock )
1882           NULLIFY( grid%domain_clock )
1883         ENDIF
1884       END SUBROUTINE domain_clock_destroy
1885
1886
1887       FUNCTION domain_last_time_step ( grid ) RESULT ( LAST_TIME )
1888         IMPLICIT NONE
1889 ! <DESCRIPTION>
1890 ! This convenience function returns .TRUE. if this is the last time
1891 ! step for domain grid.  Thanks to Tom Black.
1892 !
1893 ! </DESCRIPTION>
1894         TYPE(domain), INTENT(IN) :: grid
1895         ! result
1896         LOGICAL :: LAST_TIME
1897         LAST_TIME =   domain_get_stop_time( grid ) .EQ. &
1898                     ( domain_get_current_time( grid ) + &
1899                       domain_get_time_step( grid ) )
1900       END FUNCTION domain_last_time_step
1901
1902
1903
1904       FUNCTION domain_clockisstoptime ( grid ) RESULT ( is_stop_time )
1905         IMPLICIT NONE
1906 ! <DESCRIPTION>
1907 ! This convenience function returns .TRUE. iff grid%clock has reached its
1908 ! stop time.
1909 !
1910 ! </DESCRIPTION>
1911         TYPE(domain), INTENT(IN) :: grid
1912         ! result
1913         LOGICAL :: is_stop_time
1914         INTEGER :: rc
1915         is_stop_time = WRFU_ClockIsStopTime( grid%domain_clock , rc=rc )
1916         IF ( rc /= WRFU_SUCCESS ) THEN
1917           CALL wrf_error_fatal ( &
1918             'domain_clockisstoptime:  WRFU_ClockIsStopTime() failed' )
1919         ENDIF
1920       END FUNCTION domain_clockisstoptime
1921
1922
1923
1924       FUNCTION domain_clockisstopsubtime ( grid ) RESULT ( is_stop_subtime )
1925         IMPLICIT NONE
1926 ! <DESCRIPTION>
1927 ! This convenience function returns .TRUE. iff grid%clock has reached its
1928 ! grid%stop_subtime.
1929 !
1930 ! </DESCRIPTION>
1931         TYPE(domain), INTENT(IN) :: grid
1932         ! result
1933         LOGICAL :: is_stop_subtime
1934         INTEGER :: rc
1935         TYPE(WRFU_TimeInterval) :: timeStep
1936         TYPE(WRFU_Time) :: currentTime
1937         LOGICAL :: positive_timestep
1938         is_stop_subtime = .FALSE.
1939         CALL domain_clock_get( grid, time_step=timeStep, &
1940                                      current_time=currentTime )
1941         positive_timestep = ESMF_TimeIntervalIsPositive( timeStep )
1942         IF ( positive_timestep ) THEN
1943 ! hack for bug in PGI 5.1-x
1944 !        IF ( currentTime .GE. grid%stop_subtime ) THEN
1945           IF ( ESMF_TimeGE( currentTime, grid%stop_subtime ) ) THEN
1946             is_stop_subtime = .TRUE.
1947           ENDIF
1948         ELSE
1949 ! hack for bug in PGI 5.1-x
1950 !        IF ( currentTime .LE. grid%stop_subtime ) THEN
1951           IF ( ESMF_TimeLE( currentTime, grid%stop_subtime ) ) THEN
1952             is_stop_subtime = .TRUE.
1953           ENDIF
1954         ENDIF
1955       END FUNCTION domain_clockisstopsubtime
1956
1957
1958
1959
1960       FUNCTION domain_get_sim_start_time ( grid ) RESULT ( simulationStartTime )
1961         IMPLICIT NONE
1962 ! <DESCRIPTION>
1963 ! This convenience routine returns simulation start time for domain grid as
1964 ! a time instant.
1965 !
1966 ! If this is not a restart run, the start_time of head_grid%clock is returned
1967 ! instead.
1968 !
1969 ! Note that simulation start time remains constant through restarts while
1970 ! the start_time of head_grid%clock always refers to the start time of the
1971 ! current run (restart or otherwise).
1972 !
1973 ! </DESCRIPTION>
1974         TYPE(domain), INTENT(IN) :: grid
1975         ! result
1976         TYPE(WRFU_Time) :: simulationStartTime
1977         ! Locals
1978         INTEGER :: rc
1979         INTEGER :: simulation_start_year,   simulation_start_month, &
1980                    simulation_start_day,    simulation_start_hour , &
1981                    simulation_start_minute, simulation_start_second
1982         CALL nl_get_simulation_start_year   ( 1, simulation_start_year   )
1983         CALL nl_get_simulation_start_month  ( 1, simulation_start_month  )
1984         CALL nl_get_simulation_start_day    ( 1, simulation_start_day    )
1985         CALL nl_get_simulation_start_hour   ( 1, simulation_start_hour   )
1986         CALL nl_get_simulation_start_minute ( 1, simulation_start_minute )
1987         CALL nl_get_simulation_start_second ( 1, simulation_start_second )
1988         CALL WRFU_TimeSet( simulationStartTime,       &
1989                            YY=simulation_start_year,  &
1990                            MM=simulation_start_month, &
1991                            DD=simulation_start_day,   &
1992                            H=simulation_start_hour,   &
1993                            M=simulation_start_minute, &
1994                            S=simulation_start_second, &
1995                            rc=rc )
1996         IF ( rc /= WRFU_SUCCESS ) THEN
1997           CALL nl_get_start_year   ( 1, simulation_start_year   )
1998           CALL nl_get_start_month  ( 1, simulation_start_month  )
1999           CALL nl_get_start_day    ( 1, simulation_start_day    )
2000           CALL nl_get_start_hour   ( 1, simulation_start_hour   )
2001           CALL nl_get_start_minute ( 1, simulation_start_minute )
2002           CALL nl_get_start_second ( 1, simulation_start_second )
2003           CALL wrf_debug( 150, "WARNING:  domain_get_sim_start_time using head_grid start time from namelist" )
2004           CALL WRFU_TimeSet( simulationStartTime,       &
2005                              YY=simulation_start_year,  &
2006                              MM=simulation_start_month, &
2007                              DD=simulation_start_day,   &
2008                              H=simulation_start_hour,   &
2009                              M=simulation_start_minute, &
2010                              S=simulation_start_second, &
2011                              rc=rc )
2012         ENDIF
2013         RETURN
2014       END FUNCTION domain_get_sim_start_time
2015
2016       FUNCTION domain_get_time_since_sim_start ( grid ) RESULT ( time_since_sim_start )
2017         IMPLICIT NONE
2018 ! <DESCRIPTION>
2019 ! This convenience function returns the time elapsed since start of
2020 ! simulation for domain grid.
2021 !
2022 ! Note that simulation start time remains constant through restarts while
2023 ! the start_time of grid%clock always refers to the start time of the
2024 ! current run (restart or otherwise).
2025 !
2026 ! </DESCRIPTION>
2027         TYPE(domain), INTENT(IN) :: grid
2028         ! result
2029         TYPE(WRFU_TimeInterval) :: time_since_sim_start
2030         ! locals
2031         TYPE(WRFU_Time) :: lcl_currtime, lcl_simstarttime
2032         lcl_simstarttime = domain_get_sim_start_time( grid )
2033         lcl_currtime = domain_get_current_time ( grid )
2034         time_since_sim_start = lcl_currtime - lcl_simstarttime
2035       END FUNCTION domain_get_time_since_sim_start
2036
2037
2038
2039
2040       SUBROUTINE domain_clock_get( grid, current_time,                &
2041                                          current_timestr,             &
2042                                          current_timestr_frac,        &
2043                                          start_time, start_timestr,   &
2044                                          stop_time, stop_timestr,     &
2045                                          time_step, time_stepstr,     &
2046                                          time_stepstr_frac,           &
2047                                          advanceCount,                &
2048                                          currentDayOfYearReal,        &
2049                                          minutesSinceSimulationStart, &
2050                                          timeSinceSimulationStart,    &
2051                                          simulationStartTime,         &
2052                                          simulationStartTimeStr )
2053         IMPLICIT NONE
2054         TYPE(domain),            INTENT(IN)              :: grid
2055         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: current_time
2056         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: current_timestr
2057         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: current_timestr_frac
2058         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: start_time
2059         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: start_timestr
2060         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: stop_time
2061         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: stop_timestr
2062         TYPE(WRFU_TimeInterval), INTENT(  OUT), OPTIONAL :: time_step
2063         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: time_stepstr
2064         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: time_stepstr_frac
2065         INTEGER,                 INTENT(  OUT), OPTIONAL :: advanceCount
2066         ! currentDayOfYearReal = 0.0 at 0Z on 1 January, 0.5 at 12Z on
2067         ! 1 January, etc.
2068         REAL,                    INTENT(  OUT), OPTIONAL :: currentDayOfYearReal
2069         ! Time at which simulation started.  If this is not a restart run,
2070         ! start_time is returned instead.
2071         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: simulationStartTime
2072         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: simulationStartTimeStr
2073         ! time interval since start of simulation, includes effects of
2074         ! restarting even when restart uses a different timestep
2075         TYPE(WRFU_TimeInterval), INTENT(  OUT), OPTIONAL :: timeSinceSimulationStart
2076         ! minutes since simulation start date
2077         REAL,                    INTENT(  OUT), OPTIONAL :: minutesSinceSimulationStart
2078 ! <DESCRIPTION>
2079 ! This convenience routine returns clock information for domain grid in
2080 ! various forms.  The caller is responsible for ensuring that character
2081 ! string actual arguments are big enough.
2082 !
2083 ! </DESCRIPTION>
2084         ! Locals
2085         TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime, lcl_starttime
2086         TYPE(WRFU_Time) :: lcl_simulationStartTime
2087         TYPE(WRFU_TimeInterval) :: lcl_time_step, lcl_timeSinceSimulationStart
2088         INTEGER :: days, seconds, Sn, Sd, rc
2089         CHARACTER (LEN=256) :: tmp_str
2090         CHARACTER (LEN=256) :: frac_str
2091         REAL(WRFU_KIND_R8) :: currentDayOfYearR8
2092         IF ( PRESENT( start_time ) ) THEN
2093           start_time = domain_get_start_time ( grid )
2094         ENDIF
2095         IF ( PRESENT( start_timestr ) ) THEN
2096           lcl_starttime = domain_get_start_time ( grid )
2097           CALL wrf_timetoa ( lcl_starttime, start_timestr )
2098         ENDIF
2099         IF ( PRESENT( time_step ) ) THEN
2100           time_step = domain_get_time_step ( grid )
2101         ENDIF
2102         IF ( PRESENT( time_stepstr ) ) THEN
2103           lcl_time_step = domain_get_time_step ( grid )
2104           CALL WRFU_TimeIntervalGet( lcl_time_step, &
2105                                      timeString=time_stepstr, rc=rc )
2106           IF ( rc /= WRFU_SUCCESS ) THEN
2107             CALL wrf_error_fatal ( &
2108               'domain_clock_get:  WRFU_TimeIntervalGet() failed' )
2109           ENDIF
2110         ENDIF
2111         IF ( PRESENT( time_stepstr_frac ) ) THEN
2112           lcl_time_step = domain_get_time_step ( grid )
2113           CALL WRFU_TimeIntervalGet( lcl_time_step, timeString=tmp_str, &
2114                                      Sn=Sn, Sd=Sd, rc=rc )
2115           IF ( rc /= WRFU_SUCCESS ) THEN
2116             CALL wrf_error_fatal ( &
2117               'domain_clock_get:  WRFU_TimeIntervalGet() failed' )
2118           ENDIF
2119           CALL fraction_to_string( Sn, Sd, frac_str )
2120           time_stepstr_frac = TRIM(tmp_str)//TRIM(frac_str)
2121         ENDIF
2122         IF ( PRESENT( advanceCount ) ) THEN
2123           advanceCount = domain_get_advanceCount ( grid )
2124         ENDIF
2125         ! This duplication avoids assignment of time-manager objects
2126         ! which works now in ESMF 2.2.0 but may not work in the future
2127         ! if these objects become "deep".  We have already been bitten
2128         ! by this when the clock objects were changed from "shallow" to
2129         ! "deep".  Once again, adherence to orthodox canonical form by
2130         ! ESMF would avoid all this crap.
2131         IF ( PRESENT( current_time ) ) THEN
2132           current_time = domain_get_current_time ( grid )
2133         ENDIF
2134         IF ( PRESENT( current_timestr ) ) THEN
2135           lcl_currtime = domain_get_current_time ( grid )
2136           CALL wrf_timetoa ( lcl_currtime, current_timestr )
2137         ENDIF
2138         ! current time string including fractional part, if present
2139         IF ( PRESENT( current_timestr_frac ) ) THEN
2140           lcl_currtime = domain_get_current_time ( grid )
2141           CALL wrf_timetoa ( lcl_currtime, tmp_str )
2142           CALL WRFU_TimeGet( lcl_currtime, Sn=Sn, Sd=Sd, rc=rc )
2143           IF ( rc /= WRFU_SUCCESS ) THEN
2144             CALL wrf_error_fatal ( &
2145               'domain_clock_get:  WRFU_TimeGet() failed' )
2146           ENDIF
2147           CALL fraction_to_string( Sn, Sd, frac_str )
2148           current_timestr_frac = TRIM(tmp_str)//TRIM(frac_str)
2149         ENDIF
2150         IF ( PRESENT( stop_time ) ) THEN
2151           stop_time = domain_get_stop_time ( grid )
2152         ENDIF
2153         IF ( PRESENT( stop_timestr ) ) THEN
2154           lcl_stoptime = domain_get_stop_time ( grid )
2155           CALL wrf_timetoa ( lcl_stoptime, stop_timestr )
2156         ENDIF
2157         IF ( PRESENT( currentDayOfYearReal ) ) THEN
2158           lcl_currtime = domain_get_current_time ( grid )
2159           CALL WRFU_TimeGet( lcl_currtime, dayOfYear_r8=currentDayOfYearR8, &
2160                              rc=rc )
2161           IF ( rc /= WRFU_SUCCESS ) THEN
2162             CALL wrf_error_fatal ( &
2163                    'domain_clock_get:  WRFU_TimeGet(dayOfYear_r8) failed' )
2164           ENDIF
2165           currentDayOfYearReal = REAL( currentDayOfYearR8 ) - 1.0
2166         ENDIF
2167         IF ( PRESENT( simulationStartTime ) ) THEN
2168           simulationStartTime = domain_get_sim_start_time( grid )
2169         ENDIF
2170         IF ( PRESENT( simulationStartTimeStr ) ) THEN
2171           lcl_simulationStartTime = domain_get_sim_start_time( grid )
2172           CALL wrf_timetoa ( lcl_simulationStartTime, simulationStartTimeStr )
2173         ENDIF
2174         IF ( PRESENT( timeSinceSimulationStart ) ) THEN
2175           timeSinceSimulationStart = domain_get_time_since_sim_start( grid )
2176         ENDIF
2177         IF ( PRESENT( minutesSinceSimulationStart ) ) THEN
2178           lcl_timeSinceSimulationStart = domain_get_time_since_sim_start( grid )
2179           CALL WRFU_TimeIntervalGet( lcl_timeSinceSimulationStart, &
2180                                      D=days, S=seconds, Sn=Sn, Sd=Sd, rc=rc )
2181           IF ( rc /= WRFU_SUCCESS ) THEN
2182             CALL wrf_error_fatal ( &
2183                    'domain_clock_get:  WRFU_TimeIntervalGet() failed' )
2184           ENDIF
2185           ! get rid of hard-coded constants
2186           minutesSinceSimulationStart = ( REAL( days ) * 24. * 60. ) + &
2187                                         ( REAL( seconds ) / 60. )
2188           IF ( Sd /= 0 ) THEN
2189             minutesSinceSimulationStart = minutesSinceSimulationStart + &
2190                                           ( ( REAL( Sn ) / REAL( Sd ) ) / 60. )
2191           ENDIF
2192         ENDIF
2193         RETURN
2194       END SUBROUTINE domain_clock_get
2195
2196       FUNCTION domain_clockisstarttime ( grid ) RESULT ( is_start_time )
2197         IMPLICIT NONE
2198 ! <DESCRIPTION>
2199 ! This convenience function returns .TRUE. iff grid%clock is at its
2200 ! start time.
2201 !
2202 ! </DESCRIPTION>
2203         TYPE(domain), INTENT(IN) :: grid
2204         ! result
2205         LOGICAL :: is_start_time
2206         TYPE(WRFU_Time) :: start_time, current_time
2207         CALL domain_clock_get( grid, current_time=current_time, &
2208                                      start_time=start_time )
2209         is_start_time = ( current_time == start_time )
2210       END FUNCTION domain_clockisstarttime
2211
2212       FUNCTION domain_clockissimstarttime ( grid ) RESULT ( is_sim_start_time )
2213         IMPLICIT NONE
2214 ! <DESCRIPTION>
2215 ! This convenience function returns .TRUE. iff grid%clock is at the
2216 ! simulation start time.  (It returns .FALSE. during a restart run.)
2217 !
2218 ! </DESCRIPTION>
2219         TYPE(domain), INTENT(IN) :: grid
2220         ! result
2221         LOGICAL :: is_sim_start_time
2222         TYPE(WRFU_Time) :: simulationStartTime, current_time
2223         CALL domain_clock_get( grid, current_time=current_time, &
2224                                      simulationStartTime=simulationStartTime )
2225         is_sim_start_time = ( current_time == simulationStartTime )
2226       END FUNCTION domain_clockissimstarttime
2227
2228
2229
2230
2231       SUBROUTINE domain_clock_create( grid, StartTime, &
2232                                             StopTime,  &
2233                                             TimeStep )
2234         IMPLICIT NONE
2235         TYPE(domain),            INTENT(INOUT) :: grid
2236         TYPE(WRFU_Time),         INTENT(IN   ) :: StartTime
2237         TYPE(WRFU_Time),         INTENT(IN   ) :: StopTime
2238         TYPE(WRFU_TimeInterval), INTENT(IN   ) :: TimeStep
2239 ! <DESCRIPTION>
2240 ! This convenience routine creates the domain_clock for domain grid and
2241 ! sets associated flags.
2242 !
2243 ! </DESCRIPTION>
2244         ! Locals
2245         INTEGER :: rc
2246         grid%domain_clock = WRFU_ClockCreate( TimeStep= TimeStep,  &
2247                                               StartTime=StartTime, &
2248                                               StopTime= StopTime,  &
2249                                               rc=rc )
2250         IF ( rc /= WRFU_SUCCESS ) THEN
2251           CALL wrf_error_fatal ( &
2252             'domain_clock_create:  WRFU_ClockCreate() failed' )
2253         ENDIF
2254         grid%domain_clock_created = .TRUE.
2255         RETURN
2256       END SUBROUTINE domain_clock_create
2257
2258
2259
2260       SUBROUTINE domain_alarm_create( grid, alarm_id, interval, &
2261                                             begin_time, end_time )
2262         USE module_utility
2263         IMPLICIT NONE
2264         TYPE(domain), POINTER :: grid
2265         INTEGER, INTENT(IN) :: alarm_id
2266         TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: interval
2267         TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: begin_time
2268         TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: end_time
2269 ! <DESCRIPTION>
2270 ! This convenience routine creates alarm alarm_id for domain grid and
2271 ! sets associated flags.
2272 !
2273 ! </DESCRIPTION>
2274         ! Locals
2275         INTEGER :: rc
2276 !$$$ TBH:  Ideally, this could be simplified by passing all optional actual
2277 !$$$ TBH:  args into AlarmCreate.  However, since operations are performed on
2278 !$$$ TBH:  the actual args in-place in the calls, they must be present for the
2279 !$$$ TBH:  operations themselves to be defined.  Grrr...
2280         LOGICAL :: interval_only, all_args, no_args
2281         TYPE(WRFU_Time) :: startTime
2282         interval_only = .FALSE.
2283         all_args = .FALSE.
2284         no_args = .FALSE.
2285         IF ( ( .NOT. PRESENT( begin_time ) ) .AND. &
2286              ( .NOT. PRESENT( end_time   ) ) .AND. &
2287              (       PRESENT( interval   ) ) ) THEN
2288            interval_only = .TRUE.
2289         ELSE IF ( ( .NOT. PRESENT( begin_time ) ) .AND. &
2290                   ( .NOT. PRESENT( end_time   ) ) .AND. &
2291                   ( .NOT. PRESENT( interval   ) ) ) THEN
2292            no_args = .TRUE.
2293         ELSE IF ( (       PRESENT( begin_time ) ) .AND. &
2294                   (       PRESENT( end_time   ) ) .AND. &
2295                   (       PRESENT( interval   ) ) ) THEN
2296            all_args = .TRUE.
2297         ELSE
2298            CALL wrf_error_fatal ( &
2299              'ERROR in domain_alarm_create:  bad argument list' )
2300         ENDIF
2301         CALL domain_clock_get( grid, start_time=startTime )
2302         IF ( interval_only ) THEN
2303            grid%io_intervals( alarm_id ) = interval
2304            grid%alarms( alarm_id ) = &
2305              WRFU_AlarmCreate( clock=grid%domain_clock, &
2306                                RingInterval=interval,   &
2307                                rc=rc )
2308         ELSE IF ( no_args ) THEN
2309            grid%alarms( alarm_id ) = &
2310              WRFU_AlarmCreate( clock=grid%domain_clock, &
2311                                RingTime=startTime,      &
2312                                rc=rc )
2313         ELSE IF ( all_args ) THEN
2314            grid%io_intervals( alarm_id ) = interval
2315            grid%alarms( alarm_id ) = &
2316              WRFU_AlarmCreate( clock=grid%domain_clock,         &
2317                                RingTime=startTime + begin_time, &
2318                                RingInterval=interval,           &
2319                                StopTime=startTime + end_time,   &
2320                                rc=rc )
2321         ENDIF
2322         IF ( rc /= WRFU_SUCCESS ) THEN
2323           CALL wrf_error_fatal ( &
2324             'domain_alarm_create:  WRFU_AlarmCreate() failed' )
2325         ENDIF
2326         CALL WRFU_AlarmRingerOff( grid%alarms( alarm_id ) , rc=rc )
2327         IF ( rc /= WRFU_SUCCESS ) THEN
2328           CALL wrf_error_fatal ( &
2329             'domain_alarm_create:  WRFU_AlarmRingerOff() failed' )
2330         ENDIF
2331         grid%alarms_created( alarm_id ) = .TRUE.
2332       END SUBROUTINE domain_alarm_create
2333
2334
2335
2336       SUBROUTINE domain_clock_set( grid, current_timestr, &
2337                                          stop_timestr,    &
2338                                          time_step_seconds )
2339         IMPLICIT NONE
2340         TYPE(domain),      INTENT(INOUT)           :: grid
2341         CHARACTER (LEN=*), INTENT(IN   ), OPTIONAL :: current_timestr
2342         CHARACTER (LEN=*), INTENT(IN   ), OPTIONAL :: stop_timestr
2343         INTEGER,           INTENT(IN   ), OPTIONAL :: time_step_seconds
2344 ! <DESCRIPTION>
2345 ! This convenience routine sets clock information for domain grid.
2346 ! The caller is responsible for ensuring that character string actual
2347 ! arguments are big enough.
2348 !
2349 ! </DESCRIPTION>
2350         ! Locals
2351         TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime
2352         TYPE(WRFU_TimeInterval) :: tmpTimeInterval
2353         INTEGER :: rc
2354         IF ( PRESENT( current_timestr ) ) THEN
2355           CALL wrf_atotime( current_timestr(1:19), lcl_currtime )
2356           CALL WRFU_ClockSet( grid%domain_clock, currTime=lcl_currtime, &
2357                               rc=rc )
2358           IF ( rc /= WRFU_SUCCESS ) THEN
2359             CALL wrf_error_fatal ( &
2360               'domain_clock_set:  WRFU_ClockSet(CurrTime) failed' )
2361           ENDIF
2362         ENDIF
2363         IF ( PRESENT( stop_timestr ) ) THEN
2364           CALL wrf_atotime( stop_timestr(1:19), lcl_stoptime )
2365           CALL WRFU_ClockSet( grid%domain_clock, stopTime=lcl_stoptime, &
2366                               rc=rc )
2367           IF ( rc /= WRFU_SUCCESS ) THEN
2368             CALL wrf_error_fatal ( &
2369               'domain_clock_set:  WRFU_ClockSet(StopTime) failed' )
2370           ENDIF
2371         ENDIF
2372         IF ( PRESENT( time_step_seconds ) ) THEN
2373           CALL WRFU_TimeIntervalSet( tmpTimeInterval, &
2374                                      S=time_step_seconds, rc=rc )
2375           IF ( rc /= WRFU_SUCCESS ) THEN
2376             CALL wrf_error_fatal ( &
2377               'domain_clock_set:  WRFU_TimeIntervalSet failed' )
2378           ENDIF
2379           CALL WRFU_ClockSet ( grid%domain_clock,        &
2380                                timeStep=tmpTimeInterval, &
2381                                rc=rc )
2382           IF ( rc /= WRFU_SUCCESS ) THEN
2383             CALL wrf_error_fatal ( &
2384               'domain_clock_set:  WRFU_ClockSet(TimeStep) failed' )
2385           ENDIF
2386         ENDIF
2387         RETURN
2388       END SUBROUTINE domain_clock_set
2389
2390
2391       ! Debug routine to print key clock information.
2392       ! Printed lines include pre_str.
2393       SUBROUTINE domain_clockprint ( level, grid, pre_str )
2394         IMPLICIT NONE
2395         INTEGER,           INTENT( IN) :: level
2396         TYPE(domain),      INTENT( IN) :: grid
2397         CHARACTER (LEN=*), INTENT( IN) :: pre_str
2398         CALL wrf_clockprint ( level, grid%domain_clock, pre_str )
2399         RETURN
2400       END SUBROUTINE domain_clockprint
2401
2402
2403       ! Advance the clock associated with grid.
2404       ! Also updates several derived time quantities in grid state.
2405       SUBROUTINE domain_clockadvance ( grid )
2406         IMPLICIT NONE
2407         TYPE(domain), INTENT(INOUT) :: grid
2408         INTEGER :: rc
2409         CALL domain_clockprint ( 250, grid, &
2410           'DEBUG domain_clockadvance():  before WRFU_ClockAdvance,' )
2411         CALL WRFU_ClockAdvance( grid%domain_clock, rc=rc )
2412         IF ( rc /= WRFU_SUCCESS ) THEN
2413           CALL wrf_error_fatal ( &
2414             'domain_clockadvance:  WRFU_ClockAdvance() failed' )
2415         ENDIF
2416         CALL domain_clockprint ( 250, grid, &
2417           'DEBUG domain_clockadvance():  after WRFU_ClockAdvance,' )
2418         ! Update derived time quantities in grid state.
2419         ! These are initialized in setup_timekeeping().
2420         CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime )
2421         CALL domain_clock_get( grid, currentDayOfYearReal=grid%julian )
2422         RETURN
2423       END SUBROUTINE domain_clockadvance
2424
2425
2426
2427       ! Set grid%gmt, grid%julday, and grid%julyr from simulation-start-date.
2428       ! Set start_of_simulation to TRUE iff current_time == simulation_start_time
2429       SUBROUTINE domain_setgmtetc ( grid, start_of_simulation )
2430         IMPLICIT NONE
2431         TYPE (domain), INTENT(INOUT) :: grid
2432         LOGICAL,       INTENT(  OUT) :: start_of_simulation
2433         ! locals
2434         CHARACTER (LEN=132)          :: message
2435         TYPE(WRFU_Time)              :: simStartTime
2436         INTEGER                      :: hr, mn, sec, ms, rc
2437         CALL domain_clockprint(150, grid, &
2438           'DEBUG domain_setgmtetc():  get simStartTime from clock,')
2439         CALL domain_clock_get( grid, simulationStartTime=simStartTime, &
2440                                      simulationStartTimeStr=message )
2441         CALL WRFU_TimeGet( simStartTime, YY=grid%julyr, dayOfYear=grid%julday, &
2442                            H=hr, M=mn, S=sec, MS=ms, rc=rc)
2443         IF ( rc /= WRFU_SUCCESS ) THEN
2444           CALL wrf_error_fatal ( &
2445             'domain_setgmtetc:  WRFU_TimeGet() failed' )
2446         ENDIF
2447         WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc():  simulation start time = [',TRIM( message ),']'
2448         CALL wrf_debug( 150, TRIM(wrf_err_message) )
2449         grid%gmt=hr+real(mn)/60.+real(sec)/3600.+real(ms)/(1000*3600)
2450         WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc():  julyr,hr,mn,sec,ms,julday = ', &
2451                                      grid%julyr,hr,mn,sec,ms,grid%julday
2452         CALL wrf_debug( 150, TRIM(wrf_err_message) )
2453         WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc():  gmt = ',grid%gmt
2454         CALL wrf_debug( 150, TRIM(wrf_err_message) )
2455         start_of_simulation = domain_ClockIsSimStartTime(grid)
2456         RETURN
2457       END SUBROUTINE domain_setgmtetc
2458
2459
2460
2461       ! Set pointer to current grid.
2462       ! To begin with, current grid is not set.
2463       SUBROUTINE set_current_grid_ptr( grid_ptr )
2464         IMPLICIT NONE
2465         TYPE(domain), POINTER :: grid_ptr
2466 !PRINT *,'DEBUG:  begin set_current_grid_ptr()'
2467 !IF ( ASSOCIATED( grid_ptr ) ) THEN
2468 !  PRINT *,'DEBUG:  set_current_grid_ptr():  current_grid is associated'
2469 !ELSE
2470 !  PRINT *,'DEBUG:  set_current_grid_ptr():  current_grid is NOT associated'
2471 !ENDIF
2472         current_grid_set = .TRUE.
2473         current_grid => grid_ptr
2474 !PRINT *,'DEBUG:  end set_current_grid_ptr()'
2475       END SUBROUTINE set_current_grid_ptr
2476
2477
2478
2479 !******************************************************************************
2480 ! From Uli Blahak (01 Dec 2006)
2481 ! UB: Function to determine if the next time step is an alarm-timestep for a certain grid:
2482 !******************************************************************************
2483
2484       LOGICAL FUNCTION Is_alarm_tstep( grid_clock, alarm )
2485
2486         IMPLICIT NONE
2487
2488         TYPE (WRFU_Clock), INTENT(in)  :: grid_clock
2489         TYPE (WRFU_Alarm), INTENT(in)  :: alarm
2490
2491         LOGICAL :: pred1, pred2, pred3
2492
2493         Is_alarm_tstep = .FALSE.
2494
2495         IF ( ASSOCIATED( alarm%alarmint ) ) THEN
2496           IF ( alarm%alarmint%Enabled ) THEN
2497             IF ( alarm%alarmint%RingIntervalSet ) THEN
2498               pred1 = .FALSE. ; pred2 = .FALSE. ; pred3 = .FALSE.
2499               IF ( alarm%alarmint%StopTimeSet ) THEN
2500                  PRED1 = ( grid_clock%clockint%CurrTime + grid_clock%clockint%TimeStep > &
2501                       alarm%alarmint%StopTime )
2502               ENDIF
2503               IF ( alarm%alarmint%RingTimeSet ) THEN
2504                  PRED2 = ( ( alarm%alarmint%RingTime - &
2505                       grid_clock%clockint%TimeStep <= &
2506                       grid_clock%clockint%CurrTime )     &
2507                       .AND. ( grid_clock%clockint%CurrTime < alarm%alarmint%RingTime ) )
2508               ENDIF
2509               IF ( alarm%alarmint%RingIntervalSet ) THEN
2510                  PRED3 = ( alarm%alarmint%PrevRingTime + &
2511                       alarm%alarmint%RingInterval <= &
2512                       grid_clock%clockint%CurrTime + grid_clock%clockint%TimeStep )
2513               ENDIF
2514               IF ( ( .NOT. ( pred1 ) ) .AND. &
2515                    ( ( pred2 ) .OR. ( pred3 ) ) ) THEN
2516                  Is_alarm_tstep = .TRUE.
2517               ENDIF
2518             ELSE IF ( alarm%alarmint%RingTimeSet ) THEN
2519               IF ( alarm%alarmint%RingTime -&
2520                    grid_clock%clockint%TimeStep <= &
2521                    grid_clock%clockint%CurrTime ) THEN
2522                  Is_alarm_tstep = .TRUE.
2523               ENDIF
2524             ENDIF
2525           ENDIF
2526         ENDIF
2527
2528       END FUNCTION Is_alarm_tstep
2529
2530
2531 !******************************************************************************
2532 ! BEGIN TEST SECTION
2533 !   Code in the test section is used to test domain methods.
2534 !   This code should probably be moved elsewhere, eventually.
2535 !******************************************************************************
2536
2537       ! Private utility routines for domain_time_test.
2538       SUBROUTINE domain_time_test_print ( pre_str, name_str, res_str )
2539         IMPLICIT NONE
2540         CHARACTER (LEN=*), INTENT(IN) :: pre_str
2541         CHARACTER (LEN=*), INTENT(IN) :: name_str
2542         CHARACTER (LEN=*), INTENT(IN) :: res_str
2543         CHARACTER (LEN=512) :: out_str
2544         WRITE (out_str,                                            &
2545           FMT="('DOMAIN_TIME_TEST ',A,':  ',A,' = ',A)") &
2546           TRIM(pre_str), TRIM(name_str), TRIM(res_str)
2547         CALL wrf_debug( 0, TRIM(out_str) )
2548       END SUBROUTINE domain_time_test_print
2549
2550       ! Test adjust_io_timestr
2551       SUBROUTINE test_adjust_io_timestr( TI_h, TI_m, TI_s, &
2552         CT_yy,  CT_mm,  CT_dd,  CT_h,  CT_m,  CT_s,        &
2553         ST_yy,  ST_mm,  ST_dd,  ST_h,  ST_m,  ST_s,        &
2554         res_str, testname )
2555         INTEGER, INTENT(IN) :: TI_H
2556         INTEGER, INTENT(IN) :: TI_M
2557         INTEGER, INTENT(IN) :: TI_S
2558         INTEGER, INTENT(IN) :: CT_YY
2559         INTEGER, INTENT(IN) :: CT_MM  ! month
2560         INTEGER, INTENT(IN) :: CT_DD  ! day of month
2561         INTEGER, INTENT(IN) :: CT_H
2562         INTEGER, INTENT(IN) :: CT_M
2563         INTEGER, INTENT(IN) :: CT_S
2564         INTEGER, INTENT(IN) :: ST_YY
2565         INTEGER, INTENT(IN) :: ST_MM  ! month
2566         INTEGER, INTENT(IN) :: ST_DD  ! day of month
2567         INTEGER, INTENT(IN) :: ST_H
2568         INTEGER, INTENT(IN) :: ST_M
2569         INTEGER, INTENT(IN) :: ST_S
2570         CHARACTER (LEN=*), INTENT(IN) :: res_str
2571         CHARACTER (LEN=*), INTENT(IN) :: testname
2572         ! locals
2573         TYPE(WRFU_TimeInterval) :: TI
2574         TYPE(WRFU_Time) :: CT, ST
2575         LOGICAL :: test_passed
2576         INTEGER :: rc
2577         CHARACTER(LEN=WRFU_MAXSTR) :: TI_str, CT_str, ST_str, computed_str
2578         ! TI
2579         CALL WRFU_TimeIntervalSet( TI, H=TI_H, M=TI_M, S=TI_S, rc=rc )
2580         CALL wrf_check_error( WRFU_SUCCESS, rc, &
2581                               'FAIL:  '//TRIM(testname)//'WRFU_TimeIntervalSet() ', &
2582                               __FILE__ , &
2583                               __LINE__  )
2584         CALL WRFU_TimeIntervalGet( TI, timeString=TI_str, rc=rc )
2585         CALL wrf_check_error( WRFU_SUCCESS, rc, &
2586                               'FAIL:  '//TRIM(testname)//'WRFU_TimeGet() ', &
2587                               __FILE__ , &
2588                               __LINE__  )
2589         ! CT
2590         CALL WRFU_TimeSet( CT, YY=CT_YY, MM=CT_MM, DD=CT_DD , &
2591                                 H=CT_H,   M=CT_M,   S=CT_S, rc=rc )
2592         CALL wrf_check_error( WRFU_SUCCESS, rc, &
2593                               'FAIL:  '//TRIM(testname)//'WRFU_TimeSet() ', &
2594                               __FILE__ , &
2595                               __LINE__  )
2596         CALL WRFU_TimeGet( CT, timeString=CT_str, rc=rc )
2597         CALL wrf_check_error( WRFU_SUCCESS, rc, &
2598                               'FAIL:  '//TRIM(testname)//'WRFU_TimeGet() ', &
2599                               __FILE__ , &
2600                               __LINE__  )
2601         ! ST
2602         CALL WRFU_TimeSet( ST, YY=ST_YY, MM=ST_MM, DD=ST_DD , &
2603                                 H=ST_H,   M=ST_M,   S=ST_S, rc=rc )
2604         CALL wrf_check_error( WRFU_SUCCESS, rc, &
2605                               'FAIL:  '//TRIM(testname)//'WRFU_TimeSet() ', &
2606                               __FILE__ , &
2607                               __LINE__  )
2608         CALL WRFU_TimeGet( ST, timeString=ST_str, rc=rc )
2609         CALL wrf_check_error( WRFU_SUCCESS, rc, &
2610                               'FAIL:  '//TRIM(testname)//'WRFU_TimeGet() ', &
2611                               __FILE__ , &
2612                               __LINE__  )
2613         ! Test
2614         CALL adjust_io_timestr ( TI, CT, ST, computed_str )
2615         ! check result
2616         test_passed = .FALSE.
2617         IF ( LEN_TRIM(res_str) == LEN_TRIM(computed_str) ) THEN
2618           IF ( res_str(1:LEN_TRIM(res_str)) == computed_str(1:LEN_TRIM(computed_str)) ) THEN
2619             test_passed = .TRUE.
2620           ENDIF
2621         ENDIF
2622         ! print result
2623         IF ( test_passed ) THEN
2624           WRITE(*,FMT='(A)') 'PASS:  '//TRIM(testname)
2625         ELSE
2626           WRITE(*,*) 'FAIL:  ',TRIM(testname),':  adjust_io_timestr(',    &
2627             TRIM(TI_str),',',TRIM(CT_str),',',TRIM(ST_str),')  expected <', &
2628             TRIM(res_str),'>  but computed <',TRIM(computed_str),'>'
2629         ENDIF
2630       END SUBROUTINE test_adjust_io_timestr
2631
2632       ! Print lots of time-related information for testing and debugging.
2633       ! Printed lines include pre_str and special string DOMAIN_TIME_TEST
2634       ! suitable for grepping by test scripts.
2635       ! Returns immediately unless self_test_domain has been set to .true. in
2636       ! namelist /time_control/ .
2637       SUBROUTINE domain_time_test ( grid, pre_str )
2638         IMPLICIT NONE
2639         TYPE(domain),      INTENT(IN) :: grid
2640         CHARACTER (LEN=*), INTENT(IN) :: pre_str
2641         ! locals
2642         LOGICAL, SAVE :: one_time_tests_done = .FALSE.
2643         REAL :: minutesSinceSimulationStart
2644         INTEGER :: advance_count, rc
2645         REAL :: currentDayOfYearReal
2646         TYPE(WRFU_TimeInterval) :: timeSinceSimulationStart
2647         TYPE(WRFU_Time) :: simulationStartTime
2648         CHARACTER (LEN=512) :: res_str
2649         LOGICAL :: self_test_domain
2650         !
2651         ! NOTE:  test_adjust_io_timestr() (see below) is a self-test that
2652         !        prints PASS/FAIL/ERROR messages in a standard format.  All
2653         !        of the other tests should be strucutred the same way,
2654         !        someday.
2655         !
2656         CALL nl_get_self_test_domain( 1, self_test_domain )
2657         IF ( self_test_domain ) THEN
2658           CALL domain_clock_get( grid, advanceCount=advance_count )
2659           WRITE ( res_str, FMT="(I8.8)" ) advance_count
2660           CALL domain_time_test_print( pre_str, 'advanceCount', res_str )
2661           CALL domain_clock_get( grid, currentDayOfYearReal=currentDayOfYearReal )
2662           WRITE ( res_str, FMT='(F10.6)' ) currentDayOfYearReal
2663           CALL domain_time_test_print( pre_str, 'currentDayOfYearReal', res_str )
2664           CALL domain_clock_get( grid, minutesSinceSimulationStart=minutesSinceSimulationStart )
2665           WRITE ( res_str, FMT='(F10.6)' ) minutesSinceSimulationStart
2666           CALL domain_time_test_print( pre_str, 'minutesSinceSimulationStart', res_str )
2667           CALL domain_clock_get( grid, current_timestr=res_str )
2668           CALL domain_time_test_print( pre_str, 'current_timestr', res_str )
2669           CALL domain_clock_get( grid, current_timestr_frac=res_str )
2670           CALL domain_time_test_print( pre_str, 'current_timestr_frac', res_str )
2671           CALL domain_clock_get( grid, timeSinceSimulationStart=timeSinceSimulationStart )
2672           CALL WRFU_TimeIntervalGet( timeSinceSimulationStart, timeString=res_str, rc=rc )
2673           IF ( rc /= WRFU_SUCCESS ) THEN
2674             CALL wrf_error_fatal ( &
2675               'domain_time_test:  WRFU_TimeIntervalGet() failed' )
2676           ENDIF
2677           CALL domain_time_test_print( pre_str, 'timeSinceSimulationStart', res_str )
2678           ! The following tests should only be done once, the first time this
2679           ! routine is called.
2680           IF ( .NOT. one_time_tests_done ) THEN
2681             one_time_tests_done = .TRUE.
2682             CALL domain_clock_get( grid, simulationStartTimeStr=res_str )
2683             CALL domain_time_test_print( pre_str, 'simulationStartTime', res_str )
2684             CALL domain_clock_get( grid, start_timestr=res_str )
2685             CALL domain_time_test_print( pre_str, 'start_timestr', res_str )
2686             CALL domain_clock_get( grid, stop_timestr=res_str )
2687             CALL domain_time_test_print( pre_str, 'stop_timestr', res_str )
2688             CALL domain_clock_get( grid, time_stepstr=res_str )
2689             CALL domain_time_test_print( pre_str, 'time_stepstr', res_str )
2690             CALL domain_clock_get( grid, time_stepstr_frac=res_str )
2691             CALL domain_time_test_print( pre_str, 'time_stepstr_frac', res_str )
2692             ! Test adjust_io_timestr()
2693             !     CT = 2000-01-26_00:00:00   (current time)
2694             !     ST = 2000-01-24_12:00:00   (start time)
2695             !     TI = 00000_03:00:00        (time interval)
2696             ! the resulting time string should be:
2697             !     2000-01-26_00:00:00
2698             CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0,          &
2699               CT_yy=2000,  CT_mm=1,  CT_dd=26,  CT_h=0,  CT_m=0,  CT_s=0, &
2700               ST_yy=2000,  ST_mm=1,  ST_dd=24,  ST_h=12, ST_m=0,  ST_s=0, &
2701               res_str='2000-01-26_00:00:00', testname='adjust_io_timestr_1' )
2702             ! this should fail (and does)
2703             !  CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0,          &
2704             !    CT_yy=2000,  CT_mm=1,  CT_dd=26,  CT_h=0,  CT_m=0,  CT_s=0, &
2705             !    ST_yy=2000,  ST_mm=1,  ST_dd=24,  ST_h=12, ST_m=0,  ST_s=0, &
2706             !    res_str='2000-01-26_00:00:01', testname='adjust_io_timestr_FAIL1' )
2707           ENDIF
2708         ENDIF
2709         RETURN
2710       END SUBROUTINE domain_time_test
2711
2712 !******************************************************************************
2713 ! END TEST SECTION
2714 !******************************************************************************
2715
2716
2717 END MODULE module_domain
2718
2719
2720 ! The following routines are outside this module to avoid build dependences.
2721
2722
2723 ! Get current time as a string (current time from clock attached to the
2724 ! current_grid).  Includes fractional part, if present.
2725 ! Returns empty string if current_grid is not set or if timing has not yet
2726 ! been set up on current_grid.
2727 SUBROUTINE get_current_time_string( time_str )
2728   USE module_domain
2729   IMPLICIT NONE
2730   CHARACTER (LEN=*), INTENT(OUT) :: time_str
2731   ! locals
2732   INTEGER :: debug_level_lcl
2733 !PRINT *,'DEBUG:  begin get_current_time_string()'
2734   time_str = ''
2735   IF ( current_grid_set ) THEN
2736 !$$$DEBUG
2737 !PRINT *,'DEBUG:  get_current_time_string():  checking association of current_grid...'
2738 !IF ( ASSOCIATED( current_grid ) ) THEN
2739 !  PRINT *,'DEBUG:  get_current_time_string():  current_grid is associated'
2740 !ELSE
2741 !  PRINT *,'DEBUG:  get_current_time_string():  current_grid is NOT associated'
2742 !ENDIF
2743 !$$$END DEBUG
2744     IF ( current_grid%time_set ) THEN
2745 !PRINT *,'DEBUG:  get_current_time_string():  calling domain_clock_get()'
2746       ! set debug_level to zero and clear current_grid_set to avoid recursion
2747       CALL get_wrf_debug_level( debug_level_lcl )
2748       CALL set_wrf_debug_level ( 0 )
2749       current_grid_set = .FALSE.
2750       CALL domain_clock_get( current_grid, current_timestr_frac=time_str )
2751       ! restore debug_level and current_grid_set
2752       CALL set_wrf_debug_level ( debug_level_lcl )
2753       current_grid_set = .TRUE.
2754 !PRINT *,'DEBUG:  get_current_time_string():  back from domain_clock_get()'
2755     ENDIF
2756   ENDIF
2757 !PRINT *,'DEBUG:  end get_current_time_string()'
2758 END SUBROUTINE get_current_time_string
2759
2760
2761 ! Get current domain name as a string of form "d<NN>" where "<NN>" is
2762 ! grid%id printed in two characters, with leading zero if needed ("d01",
2763 ! "d02", etc.).
2764 ! Return empty string if current_grid not set.
2765 SUBROUTINE get_current_grid_name( grid_str )
2766   USE module_domain
2767   IMPLICIT NONE
2768   CHARACTER (LEN=*), INTENT(OUT) :: grid_str
2769   grid_str = ''
2770   IF ( current_grid_set ) THEN
2771     WRITE(grid_str,FMT="('d',I2.2)") current_grid%id
2772   ENDIF
2773 END SUBROUTINE get_current_grid_name
2774
2775
2776 ! moved these outside module domain to avoid circular reference from module_alloc_space which also uses
2777
2778    SUBROUTINE get_ijk_from_grid_ext (  grid ,                   &
2779                            ids, ide, jds, jde, kds, kde,    &
2780                            ims, ime, jms, jme, kms, kme,    &
2781                            ips, ipe, jps, jpe, kps, kpe,    &
2782                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
2783                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
2784                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
2785                            ipsy, ipey, jpsy, jpey, kpsy, kpey )
2786     USE module_domain
2787     IMPLICIT NONE
2788     TYPE( domain ), INTENT (IN)  :: grid
2789     INTEGER, INTENT(OUT) ::                                 &
2790                            ids, ide, jds, jde, kds, kde,    &
2791                            ims, ime, jms, jme, kms, kme,    &
2792                            ips, ipe, jps, jpe, kps, kpe,    &
2793                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
2794                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
2795                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
2796                            ipsy, ipey, jpsy, jpey, kpsy, kpey
2797
2798      CALL get_ijk_from_grid2 (  grid ,                   &
2799                            ids, ide, jds, jde, kds, kde,    &
2800                            ims, ime, jms, jme, kms, kme,    &
2801                            ips, ipe, jps, jpe, kps, kpe )
2802      data_ordering : SELECT CASE ( model_data_order )
2803        CASE  ( DATA_ORDER_XYZ )
2804            imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
2805            ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
2806            imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
2807            ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
2808        CASE  ( DATA_ORDER_YXZ )
2809            imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
2810            ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
2811            imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
2812            ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
2813        CASE  ( DATA_ORDER_ZXY )
2814            imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
2815            ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
2816            imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
2817            ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
2818        CASE  ( DATA_ORDER_ZYX )
2819            imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
2820            ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
2821            imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
2822            ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
2823        CASE  ( DATA_ORDER_XZY )
2824            imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
2825            ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
2826            imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
2827            ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
2828        CASE  ( DATA_ORDER_YZX )
2829            imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
2830            ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
2831            imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
2832            ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
2833      END SELECT data_ordering
2834    END SUBROUTINE get_ijk_from_grid_ext
2835
2836 ! return the values for subgrid whose refinement is in grid%sr
2837 ! note when using this routine, it does not affect K. For K
2838 ! (vertical), it just returns what get_ijk_from_grid does
2839    SUBROUTINE get_ijk_from_subgrid_ext (  grid ,                &
2840                            ids0, ide0, jds0, jde0, kds0, kde0,    &
2841                            ims0, ime0, jms0, jme0, kms0, kme0,    &
2842                            ips0, ipe0, jps0, jpe0, kps0, kpe0    )
2843     USE module_domain
2844     IMPLICIT NONE
2845     TYPE( domain ), INTENT (IN)  :: grid
2846     INTEGER, INTENT(OUT) ::                                 &
2847                            ids0, ide0, jds0, jde0, kds0, kde0,    &
2848                            ims0, ime0, jms0, jme0, kms0, kme0,    &
2849                            ips0, ipe0, jps0, jpe0, kps0, kpe0
2850    ! Local
2851     INTEGER              ::                                 &
2852                            ids, ide, jds, jde, kds, kde,    &
2853                            ims, ime, jms, jme, kms, kme,    &
2854                            ips, ipe, jps, jpe, kps, kpe
2855      CALL get_ijk_from_grid (  grid ,                         &
2856                              ids, ide, jds, jde, kds, kde,    &
2857                              ims, ime, jms, jme, kms, kme,    &
2858                              ips, ipe, jps, jpe, kps, kpe    )
2859      ids0 = ids
2860      ide0 = ide * grid%sr_x
2861      ims0 = (ims-1)*grid%sr_x+1
2862      ime0 = ime * grid%sr_x
2863      ips0 = (ips-1)*grid%sr_x+1
2864      ipe0 = ipe * grid%sr_x
2865
2866      jds0 = jds
2867      jde0 = jde * grid%sr_y
2868      jms0 = (jms-1)*grid%sr_y+1
2869      jme0 = jme * grid%sr_y
2870      jps0 = (jps-1)*grid%sr_y+1
2871      jpe0 = jpe * grid%sr_y
2872
2873      kds0 = kds
2874      kde0 = kde
2875      kms0 = kms
2876      kme0 = kme
2877      kps0 = kps
2878      kpe0 = kpe
2879    RETURN
2880    END SUBROUTINE get_ijk_from_subgrid_ext
2881
2882 ! find the grid based on the id reference and return that
2883    SUBROUTINE get_dims_from_grid_id (  id   &
2884                           ,ds, de           &
2885                           ,ms, me           &
2886                           ,ps, pe           &
2887                           ,mxs, mxe         &
2888                           ,pxs, pxe         &
2889                           ,mys, mye         &
2890                           ,pys, pye )
2891     USE module_domain, ONLY : domain, head_grid, find_grid_by_id
2892     IMPLICIT NONE
2893     TYPE( domain ), POINTER  :: grid
2894     INTEGER, INTENT(IN ) :: id
2895     INTEGER, DIMENSION(3), INTENT(INOUT) ::                   &
2896                            ds, de           &
2897                           ,ms, me           &
2898                           ,ps, pe           &
2899                           ,mxs, mxe         &
2900                           ,pxs, pxe         &
2901                           ,mys, mye         &
2902                           ,pys, pye
2903
2904      !local
2905      CHARACTER*256 mess
2906
2907      NULLIFY( grid )
2908      CALL find_grid_by_id ( id, head_grid, grid )
2909
2910      IF ( ASSOCIATED(grid) ) THEN
2911            ds(1) = grid%sd31 ; de(1) = grid%ed31 ; ds(2) = grid%sd32 ; de(2) = grid%ed32 ; ds(3) = grid%sd33 ; de(3) = grid%ed33 ;
2912            ms(1) = grid%sm31 ; me(1) = grid%em31 ; ms(2) = grid%sm32 ; me(2) = grid%em32 ; ms(3) = grid%sm33 ; me(3) = grid%em33 ;
2913            ps(1) = grid%sp31 ; pe(1) = grid%ep31 ; ps(2) = grid%sp32 ; pe(2) = grid%ep32 ; ps(3) = grid%sp33 ; pe(3) = grid%ep33 ;
2914            mxs(1) = grid%sm31x ; mxe(1) = grid%em31x
2915            mxs(2) = grid%sm32x ; mxe(2) = grid%em32x
2916            mxs(3) = grid%sm33x ; mxe(3) = grid%em33x
2917            pxs(1) = grid%sp31x ; pxe(1) = grid%ep31x
2918            pxs(2) = grid%sp32x ; pxe(2) = grid%ep32x
2919            pxs(3) = grid%sp33x ; pxe(3) = grid%ep33x
2920            mys(1) = grid%sm31y ; mye(1) = grid%em31y
2921            mys(2) = grid%sm32y ; mye(2) = grid%em32y
2922            mys(3) = grid%sm33y ; mye(3) = grid%em33y
2923            pys(1) = grid%sp31y ; pye(1) = grid%ep31y
2924            pys(2) = grid%sp32y ; pye(2) = grid%ep32y
2925            pys(3) = grid%sp33y ; pye(3) = grid%ep33y
2926      ELSE
2927         WRITE(mess,*)'internal error: get_ijk_from_grid_id: no such grid id:',id
2928         CALL wrf_error_fatal(TRIM(mess))
2929      ENDIF
2930
2931    END SUBROUTINE get_dims_from_grid_id
2932
2933 ! find the grid based on the id reference and return that
2934    SUBROUTINE get_ijk_from_grid_id (  id ,                   &
2935                            ids, ide, jds, jde, kds, kde,    &
2936                            ims, ime, jms, jme, kms, kme,    &
2937                            ips, ipe, jps, jpe, kps, kpe,    &
2938                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
2939                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
2940                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
2941                            ipsy, ipey, jpsy, jpey, kpsy, kpey )
2942     USE module_domain, ONLY : domain, head_grid, find_grid_by_id, get_ijk_from_grid
2943     IMPLICIT NONE
2944     TYPE( domain ), POINTER  :: grid
2945     INTEGER, INTENT(IN ) :: id
2946     INTEGER, INTENT(OUT) ::                                 &
2947                            ids, ide, jds, jde, kds, kde,    &
2948                            ims, ime, jms, jme, kms, kme,    &
2949                            ips, ipe, jps, jpe, kps, kpe,    &
2950                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
2951                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
2952                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
2953                            ipsy, ipey, jpsy, jpey, kpsy, kpey
2954      !local
2955      CHARACTER*256 mess
2956
2957      NULLIFY( grid )
2958      CALL find_grid_by_id ( id, head_grid, grid )
2959
2960      IF ( ASSOCIATED(grid) ) THEN
2961      CALL get_ijk_from_grid (  grid ,                   &
2962                            ids, ide, jds, jde, kds, kde,    &
2963                            ims, ime, jms, jme, kms, kme,    &
2964                            ips, ipe, jps, jpe, kps, kpe,    &
2965                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
2966                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
2967                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
2968                            ipsy, ipey, jpsy, jpey, kpsy, kpey )
2969      ELSE
2970         WRITE(mess,*)'internal error: get_ijk_from_grid_id: no such grid id:',id
2971         CALL wrf_error_fatal(TRIM(mess))
2972      ENDIF
2973
2974    END SUBROUTINE get_ijk_from_grid_id
2975
2976 ! version of this routine that can be called from set_scalar_indices_from_config in
2977 ! module_configure, which can not USE module_domain without creating a circular use assocaition
2978    SUBROUTINE modify_io_masks ( id )
2979      USE module_domain, ONLY : domain, modify_io_masks1, head_grid, find_grid_by_id
2980      IMPLICIT NONE
2981      INTEGER, INTENT(IN) :: id
2982      TYPE(domain), POINTER :: grid
2983      CALL find_grid_by_id( id, head_grid, grid )
2984      IF ( ASSOCIATED( grid ) ) CALL modify_io_masks1( grid, id )
2985      RETURN
2986    END SUBROUTINE modify_io_masks
2987