wrfv2_fire/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
  72 CONTAINS
  73
  74    SUBROUTINE adjust_domain_dims_for_move( grid , dx, dy )
  75     IMPLICIT NONE
  76
  77     TYPE( domain ), POINTER   :: grid
  78     INTEGER, INTENT(IN) ::  dx, dy
  79
  80     data_ordering : SELECT CASE ( model_data_order )
  81        CASE  ( DATA_ORDER_XYZ )
  82             grid%sm31  = grid%sm31 + dx
  83             grid%em31  = grid%em31 + dx
  84             grid%sm32  = grid%sm32 + dy
  85             grid%em32  = grid%em32 + dy
  86             grid%sp31  = grid%sp31 + dx
  87             grid%ep31  = grid%ep31 + dx
  88             grid%sp32  = grid%sp32 + dy
  89             grid%ep32  = grid%ep32 + dy
  90             grid%sd31  = grid%sd31 + dx
  91             grid%ed31  = grid%ed31 + dx
  92             grid%sd32  = grid%sd32 + dy
  93             grid%ed32  = grid%ed32 + dy
  94
  95        CASE  ( DATA_ORDER_YXZ )
  96             grid%sm31  = grid%sm31 + dy
  97             grid%em31  = grid%em31 + dy
  98             grid%sm32  = grid%sm32 + dx
  99             grid%em32  = grid%em32 + dx
 100             grid%sp31  = grid%sp31 + dy
 101             grid%ep31  = grid%ep31 + dy
 102             grid%sp32  = grid%sp32 + dx
 103             grid%ep32  = grid%ep32 + dx
 104             grid%sd31  = grid%sd31 + dy
 105             grid%ed31  = grid%ed31 + dy
 106             grid%sd32  = grid%sd32 + dx
 107             grid%ed32  = grid%ed32 + dx
 108
 109        CASE  ( DATA_ORDER_ZXY )
 110             grid%sm32  = grid%sm32 + dx
 111             grid%em32  = grid%em32 + dx
 112             grid%sm33  = grid%sm33 + dy
 113             grid%em33  = grid%em33 + dy
 114             grid%sp32  = grid%sp32 + dx
 115             grid%ep32  = grid%ep32 + dx
 116             grid%sp33  = grid%sp33 + dy
 117             grid%ep33  = grid%ep33 + dy
 118             grid%sd32  = grid%sd32 + dx
 119             grid%ed32  = grid%ed32 + dx
 120             grid%sd33  = grid%sd33 + dy
 121             grid%ed33  = grid%ed33 + dy
 122
 123        CASE  ( DATA_ORDER_ZYX )
 124             grid%sm32  = grid%sm32 + dy
 125             grid%em32  = grid%em32 + dy
 126             grid%sm33  = grid%sm33 + dx
 127             grid%em33  = grid%em33 + dx
 128             grid%sp32  = grid%sp32 + dy
 129             grid%ep32  = grid%ep32 + dy
 130             grid%sp33  = grid%sp33 + dx
 131             grid%ep33  = grid%ep33 + dx
 132             grid%sd32  = grid%sd32 + dy
 133             grid%ed32  = grid%ed32 + dy
 134             grid%sd33  = grid%sd33 + dx
 135             grid%ed33  = grid%ed33 + dx
 136
 137        CASE  ( DATA_ORDER_XZY )
 138             grid%sm31  = grid%sm31 + dx
 139             grid%em31  = grid%em31 + dx
 140             grid%sm33  = grid%sm33 + dy
 141             grid%em33  = grid%em33 + dy
 142             grid%sp31  = grid%sp31 + dx
 143             grid%ep31  = grid%ep31 + dx
 144             grid%sp33  = grid%sp33 + dy
 145             grid%ep33  = grid%ep33 + dy
 146             grid%sd31  = grid%sd31 + dx
 147             grid%ed31  = grid%ed31 + dx
 148             grid%sd33  = grid%sd33 + dy
 149             grid%ed33  = grid%ed33 + dy
 150
 151        CASE  ( DATA_ORDER_YZX )
 152             grid%sm31  = grid%sm31 + dy
 153             grid%em31  = grid%em31 + dy
 154             grid%sm33  = grid%sm33 + dx
 155             grid%em33  = grid%em33 + dx
 156             grid%sp31  = grid%sp31 + dy
 157             grid%ep31  = grid%ep31 + dy
 158             grid%sp33  = grid%sp33 + dx
 159             grid%ep33  = grid%ep33 + dx
 160             grid%sd31  = grid%sd31 + dy
 161             grid%ed31  = grid%ed31 + dy
 162             grid%sd33  = grid%sd33 + dx
 163             grid%ed33  = grid%ed33 + dx
 164
 165     END SELECT data_ordering
 166
 167 #if 0
 168     CALL dealloc_space_field ( grid )
 169
 170     CALL alloc_space_field ( grid, grid%id , 1 , 2 , .FALSE. ,     &
 171                              grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
 172                              grid%sm31,  grid%em31,  grid%sm32,  grid%em32,  grid%sm33,  grid%em33, &
 173                              grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, &   ! x-xpose
 174                              grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y  &   ! y-xpose
 175       )
 176 #endif
 177
 178     RETURN
 179    END SUBROUTINE adjust_domain_dims_for_move
 180
 181    SUBROUTINE get_ijk_from_grid1 (  grid ,                   &
 182                            ids, ide, jds, jde, kds, kde,    &
 183                            ims, ime, jms, jme, kms, kme,    &
 184                            ips, ipe, jps, jpe, kps, kpe,    &
 185                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
 186                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
 187                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
 188                            ipsy, ipey, jpsy, jpey, kpsy, kpey )
 189     IMPLICIT NONE
 190     TYPE( domain ), INTENT (IN)  :: grid
 191     INTEGER, INTENT(OUT) ::                                 &
 192                            ids, ide, jds, jde, kds, kde,    &
 193                            ims, ime, jms, jme, kms, kme,    &
 194                            ips, ipe, jps, jpe, kps, kpe,    &
 195                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
 196                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
 197                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
 198                            ipsy, ipey, jpsy, jpey, kpsy, kpey
 199
 200      CALL get_ijk_from_grid2 (  grid ,                   &
 201                            ids, ide, jds, jde, kds, kde,    &
 202                            ims, ime, jms, jme, kms, kme,    &
 203                            ips, ipe, jps, jpe, kps, kpe )
 204      data_ordering : SELECT CASE ( model_data_order )
 205        CASE  ( DATA_ORDER_XYZ )
 206            imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
 207            ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
 208            imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
 209            ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
 210        CASE  ( DATA_ORDER_YXZ )
 211            imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
 212            ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
 213            imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
 214            ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
 215        CASE  ( DATA_ORDER_ZXY )
 216            imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
 217            ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
 218            imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
 219            ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
 220        CASE  ( DATA_ORDER_ZYX )
 221            imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
 222            ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
 223            imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
 224            ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
 225        CASE  ( DATA_ORDER_XZY )
 226            imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
 227            ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
 228            imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
 229            ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
 230        CASE  ( DATA_ORDER_YZX )
 231            imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
 232            ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
 233            imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
 234            ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
 235      END SELECT data_ordering
 236    END SUBROUTINE get_ijk_from_grid1
 237
 238    SUBROUTINE get_ijk_from_grid2 (  grid ,                   &
 239                            ids, ide, jds, jde, kds, kde,    &
 240                            ims, ime, jms, jme, kms, kme,    &
 241                            ips, ipe, jps, jpe, kps, kpe )
 242
 243     IMPLICIT NONE
 244
 245     TYPE( domain ), INTENT (IN)  :: grid
 246     INTEGER, INTENT(OUT) ::                                 &
 247                            ids, ide, jds, jde, kds, kde,    &
 248                            ims, ime, jms, jme, kms, kme,    &
 249                            ips, ipe, jps, jpe, kps, kpe
 250
 251     data_ordering : SELECT CASE ( model_data_order )
 252        CASE  ( DATA_ORDER_XYZ )
 253            ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd33 ; kde = grid%ed33 ;
 254            ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm33 ; kme = grid%em33 ;
 255            ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp33 ; kpe = grid%ep33 ;
 256        CASE  ( DATA_ORDER_YXZ )
 257            ids = grid%sd32  ; ide = grid%ed32  ; jds = grid%sd31  ; jde = grid%ed31  ; kds = grid%sd33  ; kde = grid%ed33  ;
 258            ims = grid%sm32  ; ime = grid%em32  ; jms = grid%sm31  ; jme = grid%em31  ; kms = grid%sm33  ; kme = grid%em33  ;
 259            ips = grid%sp32  ; ipe = grid%ep32  ; jps = grid%sp31  ; jpe = grid%ep31  ; kps = grid%sp33  ; kpe = grid%ep33  ;
 260        CASE  ( DATA_ORDER_ZXY )
 261            ids = grid%sd32  ; ide = grid%ed32  ; jds = grid%sd33  ; jde = grid%ed33  ; kds = grid%sd31  ; kde = grid%ed31  ;
 262            ims = grid%sm32  ; ime = grid%em32  ; jms = grid%sm33  ; jme = grid%em33  ; kms = grid%sm31  ; kme = grid%em31  ;
 263            ips = grid%sp32  ; ipe = grid%ep32  ; jps = grid%sp33  ; jpe = grid%ep33  ; kps = grid%sp31  ; kpe = grid%ep31  ;
 264        CASE  ( DATA_ORDER_ZYX )
 265            ids = grid%sd33  ; ide = grid%ed33  ; jds = grid%sd32  ; jde = grid%ed32  ; kds = grid%sd31  ; kde = grid%ed31  ;
 266            ims = grid%sm33  ; ime = grid%em33  ; jms = grid%sm32  ; jme = grid%em32  ; kms = grid%sm31  ; kme = grid%em31  ;
 267            ips = grid%sp33  ; ipe = grid%ep33  ; jps = grid%sp32  ; jpe = grid%ep32  ; kps = grid%sp31  ; kpe = grid%ep31  ;
 268        CASE  ( DATA_ORDER_XZY )
 269            ids = grid%sd31  ; ide = grid%ed31  ; jds = grid%sd33  ; jde = grid%ed33  ; kds = grid%sd32  ; kde = grid%ed32  ;
 270            ims = grid%sm31  ; ime = grid%em31  ; jms = grid%sm33  ; jme = grid%em33  ; kms = grid%sm32  ; kme = grid%em32  ;
 271            ips = grid%sp31  ; ipe = grid%ep31  ; jps = grid%sp33  ; jpe = grid%ep33  ; kps = grid%sp32  ; kpe = grid%ep32  ;
 272        CASE  ( DATA_ORDER_YZX )
 273            ids = grid%sd33  ; ide = grid%ed33  ; jds = grid%sd31  ; jde = grid%ed31  ; kds = grid%sd32  ; kde = grid%ed32  ;
 274            ims = grid%sm33  ; ime = grid%em33  ; jms = grid%sm31  ; jme = grid%em31  ; kms = grid%sm32  ; kme = grid%em32  ;
 275            ips = grid%sp33  ; ipe = grid%ep33  ; jps = grid%sp31  ; jpe = grid%ep31  ; kps = grid%sp32  ; kpe = grid%ep32  ;
 276     END SELECT data_ordering
 277    END SUBROUTINE get_ijk_from_grid2
 278
 279 ! return the values for subgrid whose refinement is in grid%sr
 280 ! note when using this routine, it does not affect K. For K
 281 ! (vertical), it just returns what get_ijk_from_grid does
 282    SUBROUTINE get_ijk_from_subgrid (  grid ,                &
 283                            ids0, ide0, jds0, jde0, kds0, kde0,    &
 284                            ims0, ime0, jms0, jme0, kms0, kme0,    &
 285                            ips0, ipe0, jps0, jpe0, kps0, kpe0    )
 286     TYPE( domain ), INTENT (IN)  :: grid
 287     INTEGER, INTENT(OUT) ::                                 &
 288                            ids0, ide0, jds0, jde0, kds0, kde0,    &
 289                            ims0, ime0, jms0, jme0, kms0, kme0,    &
 290                            ips0, ipe0, jps0, jpe0, kps0, kpe0
 291    ! Local
 292     INTEGER              ::                                 &
 293                            ids, ide, jds, jde, kds, kde,    &
 294                            ims, ime, jms, jme, kms, kme,    &
 295                            ips, ipe, jps, jpe, kps, kpe
 296      CALL get_ijk_from_grid (  grid ,                         &
 297                              ids, ide, jds, jde, kds, kde,    &
 298                              ims, ime, jms, jme, kms, kme,    &
 299                              ips, ipe, jps, jpe, kps, kpe    )
 300      ids0 = ids
 301      ide0 = ide * grid%sr_x
 302      ims0 = (ims-1)*grid%sr_x+1
 303      ime0 = ime * grid%sr_x
 304      ips0 = (ips-1)*grid%sr_x+1
 305      ipe0 = ipe * grid%sr_x
 306
 307      jds0 = jds
 308      jde0 = jde * grid%sr_y
 309      jms0 = (jms-1)*grid%sr_y+1
 310      jme0 = jme * grid%sr_y
 311      jps0 = (jps-1)*grid%sr_y+1
 312      jpe0 = jpe * grid%sr_y
 313
 314      kds0 = kds
 315      kde0 = kde
 316      kms0 = kms
 317      kme0 = kme
 318      kps0 = kps
 319      kpe0 = kpe
 320    RETURN
 321    END SUBROUTINE get_ijk_from_subgrid
 322
 323
 324 ! Default version ; Otherwise module containing interface to DM library will provide
 325
 326    SUBROUTINE wrf_patch_domain( id , domdesc , parent, parent_id , parent_domdesc , &
 327                             sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
 328                             sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
 329                             sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
 330                                         sp1x , ep1x , sm1x , em1x , &
 331                                         sp2x , ep2x , sm2x , em2x , &
 332                                         sp3x , ep3x , sm3x , em3x , &
 333                                         sp1y , ep1y , sm1y , em1y , &
 334                                         sp2y , ep2y , sm2y , em2y , &
 335                                         sp3y , ep3y , sm3y , em3y , &
 336                             bdx , bdy , bdy_mask )
 337 !<DESCRIPTION>
 338 ! Wrf_patch_domain is called as part of the process of initiating a new
 339 ! domain.  Based on the global domain dimension information that is
 340 ! passed in it computes the patch and memory dimensions on this
 341 ! distributed-memory process for parallel compilation when DM_PARALLEL is
 342 ! defined in configure.wrf.  In this case, it relies on an external
 343 ! communications package-contributed routine, wrf_dm_patch_domain. For
 344 ! non-parallel compiles, it returns the patch and memory dimensions based
 345 ! on the entire domain. In either case, the memory dimensions will be
 346 ! larger than the patch dimensions, since they allow for distributed
 347 ! memory halo regions (DM_PARALLEL only) and for boundary regions around
 348 ! the domain (used for idealized cases only).  The width of the boundary
 349 ! regions to be accommodated is passed in as bdx and bdy.
 350 !
 351 ! The bdy_mask argument is a four-dimensional logical array, each element
 352 ! of which is set to true for any boundaries that this process's patch
 353 ! contains (all four are true in the non-DM_PARALLEL case) and false
 354 ! otherwise. The indices into the bdy_mask are defined in
 355 ! frame/module_state_description.F. P_XSB corresponds boundary that
 356 ! exists at the beginning of the X-dimension; ie. the western boundary;
 357 ! P_XEB to the boundary that corresponds to the end of the X-dimension
 358 ! (east). Likewise for Y (south and north respectively).
 359 !
 360 ! The correspondence of the first, second, and third dimension of each
 361 ! set (domain, memory, and patch) with the coordinate axes of the model
 362 ! domain is based on the setting of the variable model_data_order, which
 363 ! comes into this routine through USE association of
 364 ! module_driver_constants in the enclosing module of this routine,
 365 ! module_domain.  Model_data_order is defined by the Registry, based on
 366 ! the dimspec entries which associate dimension specifiers (e.g. 'k') in
 367 ! the Registry with a coordinate axis and specify which dimension of the
 368 ! arrays they represent. For WRF, the sd1 , ed1 , sp1 , ep1 , sm1 , and
 369 ! em1 correspond to the starts and ends of the global, patch, and memory
 370 ! dimensions in X; those with 2 specify Z (vertical); and those with 3
 371 ! specify Y.  Note that the WRF convention is to overdimension to allow
 372 ! for staggered fields so that sd<em>n</em>:ed<em>n</em> are the starts
 373 ! and ends of the staggered domains in X.  The non-staggered grid runs
 374 ! sd<em>n</em>:ed<em>n</em>-1. The extra row or column on the north or
 375 ! east boundaries is not used for non-staggered fields.
 376 !
 377 ! The domdesc and parent_domdesc arguments are for external communication
 378 ! packages (e.g. RSL) that establish and return to WRF integer handles
 379 ! for referring to operations on domains.  These descriptors are not set
 380 ! or used otherwise and they are opaque, which means they are never
 381 ! accessed or modified in WRF; they are only only passed between calls to
 382 ! the external package.
 383 !</DESCRIPTION>
 384
 385    USE module_machine
 386    IMPLICIT NONE
 387    LOGICAL, DIMENSION(4), INTENT(OUT)  :: bdy_mask
 388    INTEGER, INTENT(IN)   :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
 389    INTEGER, INTENT(OUT)  :: sp1  , ep1  , sp2  , ep2  , sp3  , ep3  , &  ! z-xpose (std)
 390                             sm1  , em1  , sm2  , em2  , sm3  , em3
 391    INTEGER, INTENT(OUT)  :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &  ! x-xpose
 392                             sm1x , em1x , sm2x , em2x , sm3x , em3x
 393    INTEGER, INTENT(OUT)  :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &  ! y-xpose
 394                             sm1y , em1y , sm2y , em2y , sm3y , em3y
 395    INTEGER, INTENT(IN)   :: id , parent_id , parent_domdesc
 396    INTEGER, INTENT(INOUT)  :: domdesc
 397    TYPE(domain), POINTER :: parent
 398
 399 !local data
 400
 401    INTEGER spec_bdy_width
 402
 403    CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
 404
 405 #ifndef DM_PARALLEL
 406
 407    bdy_mask = .true.     ! only one processor so all 4 boundaries are there
 408
 409 ! this is a trivial version -- 1 patch per processor;
 410 ! use version in module_dm to compute for DM
 411    sp1 = sd1 ; sp2 = sd2 ; sp3 = sd3
 412    ep1 = ed1 ; ep2 = ed2 ; ep3 = ed3
 413    SELECT CASE ( model_data_order )
 414       CASE ( DATA_ORDER_XYZ )
 415          sm1  = sp1 - bdx ; em1 = ep1 + bdx
 416          sm2  = sp2 - bdy ; em2 = ep2 + bdy
 417          sm3  = sp3       ; em3 = ep3
 418       CASE ( DATA_ORDER_YXZ )
 419          sm1 = sp1 - bdy ; em1 = ep1 + bdy
 420          sm2 = sp2 - bdx ; em2 = ep2 + bdx
 421          sm3 = sp3       ; em3 = ep3
 422       CASE ( DATA_ORDER_ZXY )
 423          sm1 = sp1       ; em1 = ep1
 424          sm2 = sp2 - bdx ; em2 = ep2 + bdx
 425          sm3 = sp3 - bdy ; em3 = ep3 + bdy
 426       CASE ( DATA_ORDER_ZYX )
 427          sm1 = sp1       ; em1 = ep1
 428          sm2 = sp2 - bdy ; em2 = ep2 + bdy
 429          sm3 = sp3 - bdx ; em3 = ep3 + bdx
 430       CASE ( DATA_ORDER_XZY )
 431          sm1 = sp1 - bdx ; em1 = ep1 + bdx
 432          sm2 = sp2       ; em2 = ep2
 433          sm3 = sp3 - bdy ; em3 = ep3 + bdy
 434       CASE ( DATA_ORDER_YZX )
 435          sm1 = sp1 - bdy ; em1 = ep1 + bdy
 436          sm2 = sp2       ; em2 = ep2
 437          sm3 = sp3 - bdx ; em3 = ep3 + bdx
 438    END SELECT
 439    sm1x = sm1       ; em1x = em1    ! just copy
 440    sm2x = sm2       ; em2x = em2
 441    sm3x = sm3       ; em3x = em3
 442    sm1y = sm1       ; em1y = em1    ! just copy
 443    sm2y = sm2       ; em2y = em2
 444    sm3y = sm3       ; em3y = em3
 445 ! assigns mostly just to suppress warning messages that INTENT OUT vars not assigned
 446    sp1x = sp1 ; ep1x = ep1 ; sp2x = sp2 ; ep2x = ep2 ; sp3x = sp3 ; ep3x = ep3
 447    sp1y = sp1 ; ep1y = ep1 ; sp2y = sp2 ; ep2y = ep2 ; sp3y = sp3 ; ep3y = ep3
 448
 449 #else
 450 ! This is supplied by the package specific version of module_dm, which
 451 ! is supplied by the external package and copied into the src directory
 452 ! when the code is compiled. The cp command will be found in the externals
 453 ! target of the configure.wrf file for this architecture.  Eg: for RSL
 454 ! routine is defined in external/RSL/module_dm.F .
 455 ! Note, it would be very nice to be able to pass parent to this routine;
 456 ! however, there doesn't seem to be a way to do that in F90. That is because
 457 ! to pass a pointer to a domain structure, this call requires an interface
 458 ! definition for wrf_dm_patch_domain (otherwise it will try to convert the
 459 ! pointer to something). In order to provide an interface definition, we
 460 ! would need to either USE module_dm or use an interface block. In either
 461 ! case it generates a circular USE reference, since module_dm uses
 462 ! module_domain.  JM 20020416
 463
 464    CALL wrf_dm_patch_domain( id , domdesc , parent_id , parent_domdesc , &
 465                              sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
 466                              sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
 467                              sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
 468                                          sp1x , ep1x , sm1x , em1x , &
 469                                          sp2x , ep2x , sm2x , em2x , &
 470                                          sp3x , ep3x , sm3x , em3x , &
 471                                          sp1y , ep1y , sm1y , em1y , &
 472                                          sp2y , ep2y , sm2y , em2y , &
 473                                          sp3y , ep3y , sm3y , em3y , &
 474                              bdx , bdy )
 475
 476    SELECT CASE ( model_data_order )
 477       CASE ( DATA_ORDER_XYZ )
 478    bdy_mask( P_XSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
 479    bdy_mask( P_YSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
 480    bdy_mask( P_XEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
 481    bdy_mask( P_YEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
 482       CASE ( DATA_ORDER_YXZ )
 483    bdy_mask( P_XSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
 484    bdy_mask( P_YSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
 485    bdy_mask( P_XEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
 486    bdy_mask( P_YEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
 487       CASE ( DATA_ORDER_ZXY )
 488    bdy_mask( P_XSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
 489    bdy_mask( P_YSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
 490    bdy_mask( P_XEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
 491    bdy_mask( P_YEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
 492       CASE ( DATA_ORDER_ZYX )
 493    bdy_mask( P_XSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
 494    bdy_mask( P_YSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
 495    bdy_mask( P_XEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
 496    bdy_mask( P_YEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
 497       CASE ( DATA_ORDER_XZY )
 498    bdy_mask( P_XSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
 499    bdy_mask( P_YSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
 500    bdy_mask( P_XEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
 501    bdy_mask( P_YEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
 502       CASE ( DATA_ORDER_YZX )
 503    bdy_mask( P_XSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
 504    bdy_mask( P_YSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
 505    bdy_mask( P_XEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
 506    bdy_mask( P_YEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
 507    END SELECT
 508
 509 #endif
 510
 511    RETURN
 512    END SUBROUTINE wrf_patch_domain
 513 !
 514    SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid )
 515
 516 !<DESCRIPTION>
 517 ! This subroutine is used to allocate a domain data structure of
 518 ! TYPE(DOMAIN) pointed to by the argument <em>grid</em>, link it into the
 519 ! nested domain hierarchy, and set it's configuration information from
 520 ! the appropriate settings in the WRF namelist file. Specifically, if the
 521 ! domain being allocated and configured is nest, the <em>parent</em>
 522 ! argument will point to the already existing domain data structure for
 523 ! the parent domain and the <em>kid</em> argument will be set to an
 524 ! integer indicating which child of the parent this grid will be (child
 525 ! indices start at 1).  If this is the top-level domain, the parent and
 526 ! kid arguments are ignored.  <b>WRF domains may have multiple children
 527 ! but only ever have one parent.</b>
 528 !
 529 ! The <em>domain_id</em> argument is the
 530 ! integer handle by which this new domain will be referred; it comes from
 531 ! the grid_id setting in the namelist, and these grid ids correspond to
 532 ! the ordering of settings in the namelist, starting with 1 for the
 533 ! top-level domain. The id of 1 always corresponds to the top-level
 534 ! domain.  and these grid ids correspond to the ordering of settings in
 535 ! the namelist, starting with 1 for the top-level domain.
 536 !
 537 ! Model_data_order is provide by USE association of
 538 ! module_driver_constants and is set from dimspec entries in the
 539 ! Registry.
 540 !
 541 ! The allocation of the TYPE(DOMAIN) itself occurs in this routine.
 542 ! However, the numerous multi-dimensional arrays that make up the members
 543 ! of the domain are allocated in the call to alloc_space_field, after
 544 ! wrf_patch_domain has been called to determine the dimensions in memory
 545 ! that should be allocated.  It bears noting here that arrays and code
 546 ! that indexes these arrays are always global, regardless of how the
 547 ! model is decomposed over patches. Thus, when arrays are allocated on a
 548 ! given process, the start and end of an array dimension are the global
 549 ! indices of the start and end of that process's subdomain.
 550 !
 551 ! Configuration information for the domain (that is, information from the
 552 ! namelist) is added by the call to <a href=med_add_config_info_to_grid.html>med_add_config_info_to_grid</a>, defined
 553 ! in share/mediation_wrfmain.F.
 554 !</DESCRIPTION>
 555
 556       USE module_alloc_space
 557       IMPLICIT NONE
 558
 559       !  Input data.
 560
 561       INTEGER , INTENT(IN)                           :: domain_id
 562       TYPE( domain ) , POINTER                       :: grid
 563       TYPE( domain ) , POINTER                       :: parent
 564       INTEGER , INTENT(IN)                           :: kid    ! which kid of parent am I?
 565
 566       !  Local data.
 567       INTEGER                     :: sd1 , ed1 , sp1 , ep1 , sm1 , em1
 568       INTEGER                     :: sd2 , ed2 , sp2 , ep2 , sm2 , em2
 569       INTEGER                     :: sd3 , ed3 , sp3 , ep3 , sm3 , em3
 570
 571       INTEGER                     :: sd1x , ed1x , sp1x , ep1x , sm1x , em1x
 572       INTEGER                     :: sd2x , ed2x , sp2x , ep2x , sm2x , em2x
 573       INTEGER                     :: sd3x , ed3x , sp3x , ep3x , sm3x , em3x
 574
 575       INTEGER                     :: sd1y , ed1y , sp1y , ep1y , sm1y , em1y
 576       INTEGER                     :: sd2y , ed2y , sp2y , ep2y , sm2y , em2y
 577       INTEGER                     :: sd3y , ed3y , sp3y , ep3y , sm3y , em3y
 578
 579       TYPE(domain) , POINTER      :: new_grid
 580       INTEGER                     :: i
 581       INTEGER                     :: parent_id , parent_domdesc , new_domdesc
 582       INTEGER                     :: bdyzone_x , bdyzone_y
 583       INTEGER                     :: nx, ny
 584
 585
 586 ! This next step uses information that is listed in the registry as namelist_derived
 587 ! to properly size the domain and the patches; this in turn is stored in the new_grid
 588 ! data structure
 589
 590
 591       data_ordering : SELECT CASE ( model_data_order )
 592         CASE  ( DATA_ORDER_XYZ )
 593
 594           CALL nl_get_s_we( domain_id , sd1 )
 595           CALL nl_get_e_we( domain_id , ed1 )
 596           CALL nl_get_s_sn( domain_id , sd2 )
 597           CALL nl_get_e_sn( domain_id , ed2 )
 598           CALL nl_get_s_vert( domain_id , sd3 )
 599           CALL nl_get_e_vert( domain_id , ed3 )
 600           nx = ed1-sd1+1
 601           ny = ed2-sd2+1
 602
 603         CASE  ( DATA_ORDER_YXZ )
 604
 605           CALL nl_get_s_sn( domain_id , sd1 )
 606           CALL nl_get_e_sn( domain_id , ed1 )
 607           CALL nl_get_s_we( domain_id , sd2 )
 608           CALL nl_get_e_we( domain_id , ed2 )
 609           CALL nl_get_s_vert( domain_id , sd3 )
 610           CALL nl_get_e_vert( domain_id , ed3 )
 611           nx = ed2-sd2+1
 612           ny = ed1-sd1+1
 613
 614         CASE  ( DATA_ORDER_ZXY )
 615
 616           CALL nl_get_s_vert( domain_id , sd1 )
 617           CALL nl_get_e_vert( 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_sn( domain_id , sd3 )
 621           CALL nl_get_e_sn( domain_id , ed3 )
 622           nx = ed2-sd2+1
 623           ny = ed3-sd3+1
 624
 625         CASE  ( DATA_ORDER_ZYX )
 626
 627           CALL nl_get_s_vert( domain_id , sd1 )
 628           CALL nl_get_e_vert( domain_id , ed1 )
 629           CALL nl_get_s_sn( domain_id , sd2 )
 630           CALL nl_get_e_sn( domain_id , ed2 )
 631           CALL nl_get_s_we( domain_id , sd3 )
 632           CALL nl_get_e_we( domain_id , ed3 )
 633           nx = ed3-sd3+1
 634           ny = ed2-sd2+1
 635
 636         CASE  ( DATA_ORDER_XZY )
 637
 638           CALL nl_get_s_we( domain_id , sd1 )
 639           CALL nl_get_e_we( domain_id , ed1 )
 640           CALL nl_get_s_vert( domain_id , sd2 )
 641           CALL nl_get_e_vert( domain_id , ed2 )
 642           CALL nl_get_s_sn( domain_id , sd3 )
 643           CALL nl_get_e_sn( domain_id , ed3 )
 644           nx = ed1-sd1+1
 645           ny = ed3-sd3+1
 646
 647         CASE  ( DATA_ORDER_YZX )
 648
 649           CALL nl_get_s_sn( domain_id , sd1 )
 650           CALL nl_get_e_sn( 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_we( domain_id , sd3 )
 654           CALL nl_get_e_we( domain_id , ed3 )
 655           nx = ed3-sd3+1
 656           ny = ed1-sd1+1
 657
 658       END SELECT data_ordering
 659
 660       IF ( num_time_levels > 3 ) THEN
 661         WRITE ( wrf_err_message , * ) 'alloc_and_configure_domain: ', &
 662           'Incorrect value for num_time_levels ', num_time_levels
 663         CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
 664       ENDIF
 665
 666       IF (ASSOCIATED(parent)) THEN
 667         parent_id = parent%id
 668         parent_domdesc = parent%domdesc
 669       ELSE
 670         parent_id = -1
 671         parent_domdesc = -1
 672       ENDIF
 673
 674 ! provided by application, WRF defines in share/module_bc.F
 675       CALL get_bdyzone_x( bdyzone_x )
 676       CALL get_bdyzone_y( bdyzone_y )
 677
 678       ALLOCATE ( new_grid )
 679       ALLOCATE ( new_grid%parents( max_parents ) )
 680       ALLOCATE ( new_grid%nests( max_nests ) )
 681       NULLIFY( new_grid%sibling )
 682       DO i = 1, max_nests
 683          NULLIFY( new_grid%nests(i)%ptr )
 684       ENDDO
 685       NULLIFY  (new_grid%next)
 686       NULLIFY  (new_grid%same_level)
 687       NULLIFY  (new_grid%i_start)
 688       NULLIFY  (new_grid%j_start)
 689       NULLIFY  (new_grid%i_end)
 690       NULLIFY  (new_grid%j_end)
 691       ALLOCATE( new_grid%domain_clock )
 692       new_grid%domain_clock_created = .FALSE.
 693       ALLOCATE( new_grid%alarms( MAX_WRF_ALARMS ) )    ! initialize in setup_timekeeping
 694       ALLOCATE( new_grid%alarms_created( MAX_WRF_ALARMS ) )
 695       DO i = 1, MAX_WRF_ALARMS
 696         new_grid%alarms_created( i ) = .FALSE.
 697       ENDDO
 698       new_grid%time_set = .FALSE.
 699
 700       ! set up the pointers that represent the nest hierarchy
 701       ! set this up *prior* to calling the patching or allocation
 702       ! routines so that implementations of these routines can
 703       ! traverse the nest hierarchy (through the root head_grid)
 704       ! if they need to
 705
 706
 707       IF ( domain_id .NE. 1 ) THEN
 708          new_grid%parents(1)%ptr => parent
 709          new_grid%num_parents = 1
 710          parent%nests(kid)%ptr => new_grid
 711          new_grid%child_of_parent(1) = kid    ! note assumption that nest can have only 1 parent
 712          parent%num_nests = parent%num_nests + 1
 713       END IF
 714       new_grid%id = domain_id                 ! this needs to be assigned prior to calling wrf_patch_domain
 715
 716       CALL wrf_patch_domain( domain_id  , new_domdesc , parent, parent_id, parent_domdesc , &
 717
 718                              sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &     ! z-xpose dims
 719                              sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &     ! (standard)
 720                              sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
 721
 722                                      sp1x , ep1x , sm1x , em1x , &     ! x-xpose dims
 723                                      sp2x , ep2x , sm2x , em2x , &
 724                                      sp3x , ep3x , sm3x , em3x , &
 725
 726                                      sp1y , ep1y , sm1y , em1y , &     ! y-xpose dims
 727                                      sp2y , ep2y , sm2y , em2y , &
 728                                      sp3y , ep3y , sm3y , em3y , &
 729
 730                          bdyzone_x  , bdyzone_y , new_grid%bdy_mask &
 731       )
 732
 733
 734       new_grid%domdesc = new_domdesc
 735       new_grid%num_nests = 0
 736       new_grid%num_siblings = 0
 737       new_grid%num_parents = 0
 738       new_grid%max_tiles   = 0
 739       new_grid%num_tiles_spec   = 0
 740       new_grid%nframes   = 0         ! initialize the number of frames per file (array assignment)
 741
 742       CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. ,      &
 743                                sd1, ed1, sd2, ed2, sd3, ed3,       &
 744                                sm1,  em1,  sm2,  em2,  sm3,  em3,  &
 745                                sm1x, em1x, sm2x, em2x, sm3x, em3x, &   ! x-xpose
 746                                sm1y, em1y, sm2y, em2y, sm3y, em3y  &   ! y-xpose
 747       )
 748 #if MOVE_NESTS
 749 !set these here, after alloc_space_field, which initializes vc_i, vc_j to zero
 750       new_grid%xi = -1.0
 751       new_grid%xj = -1.0
 752       new_grid%vc_i = -1.0
 753       new_grid%vc_j = -1.0
 754 #endif
 755
 756       new_grid%sd31                            = sd1
 757       new_grid%ed31                            = ed1
 758       new_grid%sp31                            = sp1
 759       new_grid%ep31                            = ep1
 760       new_grid%sm31                            = sm1
 761       new_grid%em31                            = em1
 762       new_grid%sd32                            = sd2
 763       new_grid%ed32                            = ed2
 764       new_grid%sp32                            = sp2
 765       new_grid%ep32                            = ep2
 766       new_grid%sm32                            = sm2
 767       new_grid%em32                            = em2
 768       new_grid%sd33                            = sd3
 769       new_grid%ed33                            = ed3
 770       new_grid%sp33                            = sp3
 771       new_grid%ep33                            = ep3
 772       new_grid%sm33                            = sm3
 773       new_grid%em33                            = em3
 774
 775       new_grid%sp31x                           = sp1x
 776       new_grid%ep31x                           = ep1x
 777       new_grid%sm31x                           = sm1x
 778       new_grid%em31x                           = em1x
 779       new_grid%sp32x                           = sp2x
 780       new_grid%ep32x                           = ep2x
 781       new_grid%sm32x                           = sm2x
 782       new_grid%em32x                           = em2x
 783       new_grid%sp33x                           = sp3x
 784       new_grid%ep33x                           = ep3x
 785       new_grid%sm33x                           = sm3x
 786       new_grid%em33x                           = em3x
 787
 788       new_grid%sp31y                           = sp1y
 789       new_grid%ep31y                           = ep1y
 790       new_grid%sm31y                           = sm1y
 791       new_grid%em31y                           = em1y
 792       new_grid%sp32y                           = sp2y
 793       new_grid%ep32y                           = ep2y
 794       new_grid%sm32y                           = sm2y
 795       new_grid%em32y                           = em2y
 796       new_grid%sp33y                           = sp3y
 797       new_grid%ep33y                           = ep3y
 798       new_grid%sm33y                           = sm3y
 799       new_grid%em33y                           = em3y
 800
 801       SELECT CASE ( model_data_order )
 802          CASE  ( DATA_ORDER_XYZ )
 803             new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
 804             new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
 805             new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
 806             new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
 807             new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
 808             new_grid%em21 = em1 ; new_grid%em22 = em2 ;
 809             new_grid%sd11 = sd1
 810             new_grid%ed11 = ed1
 811             new_grid%sp11 = sp1
 812             new_grid%ep11 = ep1
 813             new_grid%sm11 = sm1
 814             new_grid%em11 = em1
 815          CASE  ( DATA_ORDER_YXZ )
 816             new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
 817             new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
 818             new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
 819             new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
 820             new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
 821             new_grid%em21 = em1 ; new_grid%em22 = em2 ;
 822             new_grid%sd11 = sd1
 823             new_grid%ed11 = ed1
 824             new_grid%sp11 = sp1
 825             new_grid%ep11 = ep1
 826             new_grid%sm11 = sm1
 827             new_grid%em11 = em1
 828          CASE  ( DATA_ORDER_ZXY )
 829             new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
 830             new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
 831             new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
 832             new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
 833             new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
 834             new_grid%em21 = em2 ; new_grid%em22 = em3 ;
 835             new_grid%sd11 = sd2
 836             new_grid%ed11 = ed2
 837             new_grid%sp11 = sp2
 838             new_grid%ep11 = ep2
 839             new_grid%sm11 = sm2
 840             new_grid%em11 = em2
 841          CASE  ( DATA_ORDER_ZYX )
 842             new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
 843             new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
 844             new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
 845             new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
 846             new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
 847             new_grid%em21 = em2 ; new_grid%em22 = em3 ;
 848             new_grid%sd11 = sd2
 849             new_grid%ed11 = ed2
 850             new_grid%sp11 = sp2
 851             new_grid%ep11 = ep2
 852             new_grid%sm11 = sm2
 853             new_grid%em11 = em2
 854          CASE  ( DATA_ORDER_XZY )
 855             new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
 856             new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
 857             new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
 858             new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
 859             new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
 860             new_grid%em21 = em1 ; new_grid%em22 = em3 ;
 861             new_grid%sd11 = sd1
 862             new_grid%ed11 = ed1
 863             new_grid%sp11 = sp1
 864             new_grid%ep11 = ep1
 865             new_grid%sm11 = sm1
 866             new_grid%em11 = em1
 867          CASE  ( DATA_ORDER_YZX )
 868             new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
 869             new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
 870             new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
 871             new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
 872             new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
 873             new_grid%em21 = em1 ; new_grid%em22 = em3 ;
 874             new_grid%sd11 = sd1
 875             new_grid%ed11 = ed1
 876             new_grid%sp11 = sp1
 877             new_grid%ep11 = ep1
 878             new_grid%sm11 = sm1
 879             new_grid%em11 = em1
 880       END SELECT
 881
 882       CALL med_add_config_info_to_grid ( new_grid )           ! this is a mediation layer routine
 883
 884 ! Some miscellaneous state that is in the Registry but not namelist data
 885
 886       new_grid%tiled                           = .false.
 887       new_grid%patched                         = .false.
 888       NULLIFY(new_grid%mapping)
 889
 890 ! This next set of includes causes all but the namelist_derived variables to be
 891 ! properly assigned to the new_grid record
 892
 893       grid => new_grid
 894
 895 ! Allocate storage for time series metadata
 896       ALLOCATE( grid%lattsloc( grid%max_ts_locs ) )
 897       ALLOCATE( grid%lontsloc( grid%max_ts_locs ) )
 898       ALLOCATE( grid%nametsloc( grid%max_ts_locs ) )
 899       ALLOCATE( grid%desctsloc( grid%max_ts_locs ) )
 900       ALLOCATE( grid%itsloc( grid%max_ts_locs ) )
 901       ALLOCATE( grid%jtsloc( grid%max_ts_locs ) )
 902       ALLOCATE( grid%id_tsloc( grid%max_ts_locs ) )
 903       ALLOCATE( grid%ts_filename( grid%max_ts_locs ) )
 904       grid%ntsloc        = 0
 905       grid%ntsloc_domain = 0
 906
 907 #ifdef DM_PARALLEL
 908       CALL wrf_get_dm_communicator ( grid%communicator )
 909       CALL wrf_dm_define_comms( grid )
 910 #endif
 911
 912    END SUBROUTINE alloc_and_configure_domain
 913
 914 !
 915
 916 !  This routine ALLOCATEs the required space for the meteorological fields
 917 !  for a specific domain.  The fields are simply ALLOCATEd as an -1.  They
 918 !  are referenced as wind, temperature, moisture, etc. in routines that are
 919 !  below this top-level of data allocation and management (in the solve routine
 920 !  and below).
 921
 922    SUBROUTINE alloc_space_field ( grid,   id, setinitval_in ,  tl_in , inter_domain_in ,   &
 923                                   sd31, ed31, sd32, ed32, sd33, ed33, &
 924                                   sm31 , em31 , sm32 , em32 , sm33 , em33 , &
 925                                   sm31x, em31x, sm32x, em32x, sm33x, em33x, &
 926                                   sm31y, em31y, sm32y, em32y, sm33y, em33y )
 927
 928       USE module_alloc_space, ONLY : alloc_space_field_core
 929       IMPLICIT NONE
 930
 931       !  Input data.
 932
 933       TYPE(domain)               , POINTER          :: grid
 934       INTEGER , INTENT(IN)            :: id
 935       INTEGER , INTENT(IN)            :: setinitval_in   ! 3 = everything, 1 = arrays only, 0 = none
 936       INTEGER , INTENT(IN)            :: sd31, ed31, sd32, ed32, sd33, ed33
 937       INTEGER , INTENT(IN)            :: sm31, em31, sm32, em32, sm33, em33
 938       INTEGER , INTENT(IN)            :: sm31x, em31x, sm32x, em32x, sm33x, em33x
 939       INTEGER , INTENT(IN)            :: sm31y, em31y, sm32y, em32y, sm33y, em33y
 940
 941       ! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.
 942       ! e.g. to set both 1st and second time level, use 3
 943       !      to set only 1st                        use 1
 944       !      to set only 2st                        use 2
 945       INTEGER , INTENT(IN)            :: tl_in
 946
 947       ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated
 948       ! false otherwise (all allocated, modulo tl above)
 949       LOGICAL , INTENT(IN)            :: inter_domain_in
 950
 951       ! now a separate module in WRFV3 to reduce the size of module_domain that the compiler sees
 952       CALL alloc_space_field_core ( grid,   id, setinitval_in ,  tl_in , inter_domain_in ,   &
 953                                     sd31, ed31, sd32, ed32, sd33, ed33, &
 954                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
 955                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
 956                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
 957
 958    END SUBROUTINE alloc_space_field
 959
 960 !  This routine is used to DEALLOCATE space for a single domain and remove
 961 !  it from the linked list.  First the pointers in the linked list are fixed
 962 !  (so the one in the middle can be removed).  Then the domain itself is
 963 !  DEALLOCATEd via a call to domain_destroy().
 964
 965    SUBROUTINE dealloc_space_domain ( id )
 966
 967       IMPLICIT NONE
 968
 969       !  Input data.
 970
 971       INTEGER , INTENT(IN)            :: id
 972
 973       !  Local data.
 974
 975       TYPE(domain) , POINTER          :: grid
 976       LOGICAL                         :: found
 977
 978       !  Initializations required to start the routine.
 979
 980       grid => head_grid
 981       old_grid => head_grid
 982       found = .FALSE.
 983
 984       !  The identity of the domain to delete is based upon the "id".
 985       !  We search all of the possible grids.  It is required to find a domain
 986       !  otherwise it is a fatal error.
 987
 988       find_grid : DO WHILE ( ASSOCIATED(grid) )
 989          IF ( grid%id == id ) THEN
 990             found = .TRUE.
 991             old_grid%next => grid%next
 992             CALL domain_destroy( grid )
 993             EXIT find_grid
 994          END IF
 995          old_grid => grid
 996          grid     => grid%next
 997       END DO find_grid
 998
 999       IF ( .NOT. found ) THEN
1000          WRITE ( wrf_err_message , * ) 'module_domain: ', &
1001            'dealloc_space_domain: Could not de-allocate grid id ',id
1002          CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1003       END IF
1004
1005    END SUBROUTINE dealloc_space_domain
1006
1007
1008
1009 !  This routine is used to DEALLOCATE space for a single domain type.
1010 !  First, the field data are all removed through a CALL to the
1011 !  dealloc_space_field routine.  Then the pointer to the domain
1012 !  itself is DEALLOCATEd.
1013
1014    SUBROUTINE domain_destroy ( grid )
1015
1016       IMPLICIT NONE
1017
1018       !  Input data.
1019
1020       TYPE(domain) , POINTER          :: grid
1021
1022       CALL dealloc_space_field ( grid )
1023       DEALLOCATE( grid%parents )
1024       DEALLOCATE( grid%nests )
1025       ! clean up time manager bits
1026       CALL domain_clock_destroy( grid )
1027       CALL domain_alarms_destroy( grid )
1028       IF ( ASSOCIATED( grid%i_start ) ) THEN
1029         DEALLOCATE( grid%i_start )
1030       ENDIF
1031       IF ( ASSOCIATED( grid%i_end ) ) THEN
1032         DEALLOCATE( grid%i_end )
1033       ENDIF
1034       IF ( ASSOCIATED( grid%j_start ) ) THEN
1035         DEALLOCATE( grid%j_start )
1036       ENDIF
1037       IF ( ASSOCIATED( grid%j_end ) ) THEN
1038         DEALLOCATE( grid%j_end )
1039       ENDIF
1040       IF ( ASSOCIATED( grid%itsloc ) ) THEN
1041         DEALLOCATE( grid%itsloc )
1042       ENDIF
1043       IF ( ASSOCIATED( grid%jtsloc ) ) THEN
1044         DEALLOCATE( grid%jtsloc )
1045       ENDIF
1046       IF ( ASSOCIATED( grid%id_tsloc ) ) THEN
1047         DEALLOCATE( grid%id_tsloc )
1048       ENDIF
1049       IF ( ASSOCIATED( grid%lattsloc ) ) THEN
1050         DEALLOCATE( grid%lattsloc )
1051       ENDIF
1052       IF ( ASSOCIATED( grid%lontsloc ) ) THEN
1053         DEALLOCATE( grid%lontsloc )
1054       ENDIF
1055       IF ( ASSOCIATED( grid%nametsloc ) ) THEN
1056         DEALLOCATE( grid%nametsloc )
1057       ENDIF
1058       IF ( ASSOCIATED( grid%desctsloc ) ) THEN
1059         DEALLOCATE( grid%desctsloc )
1060       ENDIF
1061       IF ( ASSOCIATED( grid%ts_filename ) ) THEN
1062         DEALLOCATE( grid%ts_filename )
1063       ENDIF
1064       DEALLOCATE( grid )
1065       NULLIFY( grid )
1066
1067    END SUBROUTINE domain_destroy
1068
1069    RECURSIVE SUBROUTINE show_nest_subtree ( grid )
1070       TYPE(domain), POINTER :: grid
1071       INTEGER myid
1072       INTEGER kid
1073       IF ( .NOT. ASSOCIATED( grid ) ) RETURN
1074       myid = grid%id
1075       write(0,*)'show_nest_subtree ',myid
1076       DO kid = 1, max_nests
1077         IF ( ASSOCIATED( grid%nests(kid)%ptr ) ) THEN
1078           IF ( grid%nests(kid)%ptr%id .EQ. myid ) THEN
1079             CALL wrf_error_fatal( 'show_nest_subtree: nest hierarchy corrupted' )
1080           ENDIF
1081           CALL show_nest_subtree( grid%nests(kid)%ptr )
1082         ENDIF
1083       ENDDO
1084    END SUBROUTINE show_nest_subtree
1085
1086
1087 !
1088
1089 !  This routine DEALLOCATEs each gridded field for this domain.  For each type of
1090 !  different array (1d, 2d, 3d, etc.), the space for each pointer is DEALLOCATEd
1091 !  for every -1 (i.e., each different meteorological field).
1092
1093    SUBROUTINE dealloc_space_field ( grid )
1094
1095       IMPLICIT NONE
1096
1097       !  Input data.
1098
1099       TYPE(domain)              , POINTER :: grid
1100
1101       !  Local data.
1102
1103       INTEGER                             ::  ierr
1104
1105 # include <deallocs.inc>
1106
1107    END SUBROUTINE dealloc_space_field
1108
1109 !
1110 !
1111    RECURSIVE SUBROUTINE find_grid_by_id ( id, in_grid, result_grid )
1112       IMPLICIT NONE
1113       INTEGER, INTENT(IN) :: id
1114       TYPE(domain), POINTER     :: in_grid
1115       TYPE(domain), POINTER     :: result_grid
1116 ! <DESCRIPTION>
1117 ! This is a recursive subroutine that traverses the domain hierarchy rooted
1118 ! at the input argument <em>in_grid</em>, a pointer to TYPE(domain), and returns
1119 ! a pointer to the domain matching the integer argument <em>id</em> if it exists.
1120 !
1121 ! </DESCRIPTION>
1122       TYPE(domain), POINTER     :: grid_ptr
1123       INTEGER                   :: kid
1124       LOGICAL                   :: found
1125       found = .FALSE.
1126       IF ( ASSOCIATED( in_grid ) ) THEN
1127       IF ( in_grid%id .EQ. id ) THEN
1128          result_grid => in_grid
1129       ELSE
1130          grid_ptr => in_grid
1131          DO WHILE ( ASSOCIATED( grid_ptr ) .AND. .NOT. found )
1132             DO kid = 1, max_nests
1133                IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) .AND. .NOT. found ) THEN
1134                   CALL find_grid_by_id ( id, grid_ptr%nests(kid)%ptr, result_grid )
1135                   IF ( ASSOCIATED( result_grid ) ) THEN
1136                     IF ( result_grid%id .EQ. id ) found = .TRUE.
1137                   ENDIF
1138                ENDIF
1139             ENDDO
1140             IF ( .NOT. found ) grid_ptr => grid_ptr%sibling
1141          ENDDO
1142       ENDIF
1143       ENDIF
1144       RETURN
1145    END SUBROUTINE find_grid_by_id
1146
1147
1148    FUNCTION first_loc_integer ( array , search ) RESULT ( loc )
1149
1150       IMPLICIT NONE
1151
1152       !  Input data.
1153
1154       INTEGER , INTENT(IN) , DIMENSION(:) :: array
1155       INTEGER , INTENT(IN)                :: search
1156
1157       !  Output data.
1158
1159       INTEGER                             :: loc
1160
1161 !<DESCRIPTION>
1162 !  This routine is used to find a specific domain identifier in an array
1163 !  of domain identifiers.
1164 !
1165 !</DESCRIPTION>
1166
1167       !  Local data.
1168
1169       INTEGER :: loop
1170
1171       loc = -1
1172       find : DO loop = 1 , SIZE(array)
1173          IF ( search == array(loop) ) THEN
1174             loc = loop
1175             EXIT find
1176          END IF
1177       END DO find
1178
1179    END FUNCTION first_loc_integer
1180 !
1181    SUBROUTINE init_module_domain
1182    END SUBROUTINE init_module_domain
1183
1184
1185 ! <DESCRIPTION>
1186 !
1187 ! The following routines named domain_*() are convenience routines that
1188 ! eliminate many duplicated bits of code.  They provide shortcuts for the
1189 ! most common operations on the domain_clock field of TYPE(domain).
1190 !
1191 ! </DESCRIPTION>
1192
1193       FUNCTION domain_get_current_time ( grid ) RESULT ( current_time )
1194         IMPLICIT NONE
1195 ! <DESCRIPTION>
1196 ! This convenience function returns the current time for domain grid.
1197 !
1198 ! </DESCRIPTION>
1199         TYPE(domain), INTENT(IN) :: grid
1200         ! result
1201         TYPE(WRFU_Time) :: current_time
1202         ! locals
1203         INTEGER :: rc
1204         CALL WRFU_ClockGet( grid%domain_clock, CurrTime=current_time, &
1205                             rc=rc )
1206         IF ( rc /= WRFU_SUCCESS ) THEN
1207           CALL wrf_error_fatal ( &
1208             'domain_get_current_time:  WRFU_ClockGet failed' )
1209         ENDIF
1210       END FUNCTION domain_get_current_time
1211
1212
1213       FUNCTION domain_get_start_time ( grid ) RESULT ( start_time )
1214         IMPLICIT NONE
1215 ! <DESCRIPTION>
1216 ! This convenience function returns the start time for domain grid.
1217 !
1218 ! </DESCRIPTION>
1219         TYPE(domain), INTENT(IN) :: grid
1220         ! result
1221         TYPE(WRFU_Time) :: start_time
1222         ! locals
1223         INTEGER :: rc
1224         CALL WRFU_ClockGet( grid%domain_clock, StartTime=start_time, &
1225                             rc=rc )
1226         IF ( rc /= WRFU_SUCCESS ) THEN
1227           CALL wrf_error_fatal ( &
1228             'domain_get_start_time:  WRFU_ClockGet failed' )
1229         ENDIF
1230       END FUNCTION domain_get_start_time
1231
1232
1233       FUNCTION domain_get_stop_time ( grid ) RESULT ( stop_time )
1234         IMPLICIT NONE
1235 ! <DESCRIPTION>
1236 ! This convenience function returns the stop time for domain grid.
1237 !
1238 ! </DESCRIPTION>
1239         TYPE(domain), INTENT(IN) :: grid
1240         ! result
1241         TYPE(WRFU_Time) :: stop_time
1242         ! locals
1243         INTEGER :: rc
1244         CALL WRFU_ClockGet( grid%domain_clock, StopTime=stop_time, &
1245                             rc=rc )
1246         IF ( rc /= WRFU_SUCCESS ) THEN
1247           CALL wrf_error_fatal ( &
1248             'domain_get_stop_time:  WRFU_ClockGet failed' )
1249         ENDIF
1250       END FUNCTION domain_get_stop_time
1251
1252
1253       FUNCTION domain_get_time_step ( grid ) RESULT ( time_step )
1254         IMPLICIT NONE
1255 ! <DESCRIPTION>
1256 ! This convenience function returns the time step for domain grid.
1257 !
1258 ! </DESCRIPTION>
1259         TYPE(domain), INTENT(IN) :: grid
1260         ! result
1261         TYPE(WRFU_TimeInterval) :: time_step
1262         ! locals
1263         INTEGER :: rc
1264         CALL WRFU_ClockGet( grid%domain_clock, timeStep=time_step, &
1265                             rc=rc )
1266         IF ( rc /= WRFU_SUCCESS ) THEN
1267           CALL wrf_error_fatal ( &
1268             'domain_get_time_step:  WRFU_ClockGet failed' )
1269         ENDIF
1270       END FUNCTION domain_get_time_step
1271
1272
1273       FUNCTION domain_get_advanceCount ( grid ) RESULT ( advanceCount )
1274         IMPLICIT NONE
1275 ! <DESCRIPTION>
1276 ! This convenience function returns the time step for domain grid.
1277 ! Also converts from INTEGER(WRFU_KIND_I8) to INTEGER.
1278 !
1279 ! </DESCRIPTION>
1280         TYPE(domain), INTENT(IN) :: grid
1281         ! result
1282         INTEGER :: advanceCount
1283         ! locals
1284         INTEGER(WRFU_KIND_I8) :: advanceCountLcl
1285         INTEGER :: rc
1286         CALL WRFU_ClockGet( grid%domain_clock, &
1287                             advanceCount=advanceCountLcl, &
1288                             rc=rc )
1289         IF ( rc /= WRFU_SUCCESS ) THEN
1290           CALL wrf_error_fatal ( &
1291             'domain_get_advanceCount:  WRFU_ClockGet failed' )
1292         ENDIF
1293         advanceCount = advanceCountLcl
1294       END FUNCTION domain_get_advanceCount
1295
1296
1297       SUBROUTINE domain_alarms_destroy ( grid )
1298         IMPLICIT NONE
1299 ! <DESCRIPTION>
1300 ! This convenience routine destroys and deallocates all alarms associated
1301 ! with grid.
1302 !
1303 ! </DESCRIPTION>
1304         TYPE(domain), INTENT(INOUT) :: grid
1305         !  Local data.
1306         INTEGER                     :: alarmid
1307
1308         IF ( ASSOCIATED( grid%alarms ) .AND. &
1309              ASSOCIATED( grid%alarms_created ) ) THEN
1310           DO alarmid = 1, MAX_WRF_ALARMS
1311             IF ( grid%alarms_created( alarmid ) ) THEN
1312               CALL WRFU_AlarmDestroy( grid%alarms( alarmid ) )
1313               grid%alarms_created( alarmid ) = .FALSE.
1314             ENDIF
1315           ENDDO
1316           DEALLOCATE( grid%alarms )
1317           NULLIFY( grid%alarms )
1318           DEALLOCATE( grid%alarms_created )
1319           NULLIFY( grid%alarms_created )
1320         ENDIF
1321       END SUBROUTINE domain_alarms_destroy
1322
1323
1324       SUBROUTINE domain_clock_destroy ( grid )
1325         IMPLICIT NONE
1326 ! <DESCRIPTION>
1327 ! This convenience routine destroys and deallocates the domain clock.
1328 !
1329 ! </DESCRIPTION>
1330         TYPE(domain), INTENT(INOUT) :: grid
1331         IF ( ASSOCIATED( grid%domain_clock ) ) THEN
1332           IF ( grid%domain_clock_created ) THEN
1333             CALL WRFU_ClockDestroy( grid%domain_clock )
1334             grid%domain_clock_created = .FALSE.
1335           ENDIF
1336           DEALLOCATE( grid%domain_clock )
1337           NULLIFY( grid%domain_clock )
1338         ENDIF
1339       END SUBROUTINE domain_clock_destroy
1340
1341
1342       FUNCTION domain_last_time_step ( grid ) RESULT ( LAST_TIME )
1343         IMPLICIT NONE
1344 ! <DESCRIPTION>
1345 ! This convenience function returns .TRUE. if this is the last time
1346 ! step for domain grid.  Thanks to Tom Black.
1347 !
1348 ! </DESCRIPTION>
1349         TYPE(domain), INTENT(IN) :: grid
1350         ! result
1351         LOGICAL :: LAST_TIME
1352         LAST_TIME =   domain_get_stop_time( grid ) .EQ. &
1353                     ( domain_get_current_time( grid ) + &
1354                       domain_get_time_step( grid ) )
1355       END FUNCTION domain_last_time_step
1356
1357
1358
1359       FUNCTION domain_clockisstoptime ( grid ) RESULT ( is_stop_time )
1360         IMPLICIT NONE
1361 ! <DESCRIPTION>
1362 ! This convenience function returns .TRUE. iff grid%clock has reached its
1363 ! stop time.
1364 !
1365 ! </DESCRIPTION>
1366         TYPE(domain), INTENT(IN) :: grid
1367         ! result
1368         LOGICAL :: is_stop_time
1369         INTEGER :: rc
1370         is_stop_time = WRFU_ClockIsStopTime( grid%domain_clock , rc=rc )
1371         IF ( rc /= WRFU_SUCCESS ) THEN
1372           CALL wrf_error_fatal ( &
1373             'domain_clockisstoptime:  WRFU_ClockIsStopTime() failed' )
1374         ENDIF
1375       END FUNCTION domain_clockisstoptime
1376
1377
1378
1379       FUNCTION domain_clockisstopsubtime ( grid ) RESULT ( is_stop_subtime )
1380         IMPLICIT NONE
1381 ! <DESCRIPTION>
1382 ! This convenience function returns .TRUE. iff grid%clock has reached its
1383 ! grid%stop_subtime.
1384 !
1385 ! </DESCRIPTION>
1386         TYPE(domain), INTENT(IN) :: grid
1387         ! result
1388         LOGICAL :: is_stop_subtime
1389         INTEGER :: rc
1390         TYPE(WRFU_TimeInterval) :: timeStep
1391         TYPE(WRFU_Time) :: currentTime
1392         LOGICAL :: positive_timestep
1393         is_stop_subtime = .FALSE.
1394         CALL domain_clock_get( grid, time_step=timeStep, &
1395                                      current_time=currentTime )
1396         positive_timestep = ESMF_TimeIntervalIsPositive( timeStep )
1397         IF ( positive_timestep ) THEN
1398 ! hack for bug in PGI 5.1-x
1399 !        IF ( currentTime .GE. grid%stop_subtime ) THEN
1400           IF ( ESMF_TimeGE( currentTime, grid%stop_subtime ) ) THEN
1401             is_stop_subtime = .TRUE.
1402           ENDIF
1403         ELSE
1404 ! hack for bug in PGI 5.1-x
1405 !        IF ( currentTime .LE. grid%stop_subtime ) THEN
1406           IF ( ESMF_TimeLE( currentTime, grid%stop_subtime ) ) THEN
1407             is_stop_subtime = .TRUE.
1408           ENDIF
1409         ENDIF
1410       END FUNCTION domain_clockisstopsubtime
1411
1412
1413
1414
1415       FUNCTION domain_get_sim_start_time ( grid ) RESULT ( simulationStartTime )
1416         IMPLICIT NONE
1417 ! <DESCRIPTION>
1418 ! This convenience routine returns simulation start time for domain grid as
1419 ! a time instant.
1420 !
1421 ! If this is not a restart run, the start_time of head_grid%clock is returned
1422 ! instead.
1423 !
1424 ! Note that simulation start time remains constant through restarts while
1425 ! the start_time of head_grid%clock always refers to the start time of the
1426 ! current run (restart or otherwise).
1427 !
1428 ! </DESCRIPTION>
1429         TYPE(domain), INTENT(IN) :: grid
1430         ! result
1431         TYPE(WRFU_Time) :: simulationStartTime
1432         ! Locals
1433         INTEGER :: rc
1434         INTEGER :: simulation_start_year,   simulation_start_month, &
1435                    simulation_start_day,    simulation_start_hour , &
1436                    simulation_start_minute, simulation_start_second
1437         CALL nl_get_simulation_start_year   ( 1, simulation_start_year   )
1438         CALL nl_get_simulation_start_month  ( 1, simulation_start_month  )
1439         CALL nl_get_simulation_start_day    ( 1, simulation_start_day    )
1440         CALL nl_get_simulation_start_hour   ( 1, simulation_start_hour   )
1441         CALL nl_get_simulation_start_minute ( 1, simulation_start_minute )
1442         CALL nl_get_simulation_start_second ( 1, simulation_start_second )
1443         CALL WRFU_TimeSet( simulationStartTime,       &
1444                            YY=simulation_start_year,  &
1445                            MM=simulation_start_month, &
1446                            DD=simulation_start_day,   &
1447                            H=simulation_start_hour,   &
1448                            M=simulation_start_minute, &
1449                            S=simulation_start_second, &
1450                            rc=rc )
1451         IF ( rc /= WRFU_SUCCESS ) THEN
1452           CALL nl_get_start_year   ( 1, simulation_start_year   )
1453           CALL nl_get_start_month  ( 1, simulation_start_month  )
1454           CALL nl_get_start_day    ( 1, simulation_start_day    )
1455           CALL nl_get_start_hour   ( 1, simulation_start_hour   )
1456           CALL nl_get_start_minute ( 1, simulation_start_minute )
1457           CALL nl_get_start_second ( 1, simulation_start_second )
1458           CALL wrf_debug( 150, "WARNING:  domain_get_sim_start_time using head_grid start time from namelist" )
1459           CALL WRFU_TimeSet( simulationStartTime,       &
1460                              YY=simulation_start_year,  &
1461                              MM=simulation_start_month, &
1462                              DD=simulation_start_day,   &
1463                              H=simulation_start_hour,   &
1464                              M=simulation_start_minute, &
1465                              S=simulation_start_second, &
1466                              rc=rc )
1467         ENDIF
1468         RETURN
1469       END FUNCTION domain_get_sim_start_time
1470
1471       FUNCTION domain_get_time_since_sim_start ( grid ) RESULT ( time_since_sim_start )
1472         IMPLICIT NONE
1473 ! <DESCRIPTION>
1474 ! This convenience function returns the time elapsed since start of
1475 ! simulation for domain grid.
1476 !
1477 ! Note that simulation start time remains constant through restarts while
1478 ! the start_time of grid%clock always refers to the start time of the
1479 ! current run (restart or otherwise).
1480 !
1481 ! </DESCRIPTION>
1482         TYPE(domain), INTENT(IN) :: grid
1483         ! result
1484         TYPE(WRFU_TimeInterval) :: time_since_sim_start
1485         ! locals
1486         TYPE(WRFU_Time) :: lcl_currtime, lcl_simstarttime
1487         lcl_simstarttime = domain_get_sim_start_time( grid )
1488         lcl_currtime = domain_get_current_time ( grid )
1489         time_since_sim_start = lcl_currtime - lcl_simstarttime
1490       END FUNCTION domain_get_time_since_sim_start
1491
1492
1493
1494
1495       SUBROUTINE domain_clock_get( grid, current_time,                &
1496                                          current_timestr,             &
1497                                          current_timestr_frac,        &
1498                                          start_time, start_timestr,   &
1499                                          stop_time, stop_timestr,     &
1500                                          time_step, time_stepstr,     &
1501                                          time_stepstr_frac,           &
1502                                          advanceCount,                &
1503                                          currentDayOfYearReal,        &
1504                                          minutesSinceSimulationStart, &
1505                                          timeSinceSimulationStart,    &
1506                                          simulationStartTime,         &
1507                                          simulationStartTimeStr )
1508         IMPLICIT NONE
1509         TYPE(domain),            INTENT(IN)              :: grid
1510         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: current_time
1511         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: current_timestr
1512         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: current_timestr_frac
1513         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: start_time
1514         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: start_timestr
1515         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: stop_time
1516         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: stop_timestr
1517         TYPE(WRFU_TimeInterval), INTENT(  OUT), OPTIONAL :: time_step
1518         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: time_stepstr
1519         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: time_stepstr_frac
1520         INTEGER,                 INTENT(  OUT), OPTIONAL :: advanceCount
1521         ! currentDayOfYearReal = 0.0 at 0Z on 1 January, 0.5 at 12Z on
1522         ! 1 January, etc.
1523         REAL,                    INTENT(  OUT), OPTIONAL :: currentDayOfYearReal
1524         ! Time at which simulation started.  If this is not a restart run,
1525         ! start_time is returned instead.
1526         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: simulationStartTime
1527         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: simulationStartTimeStr
1528         ! time interval since start of simulation, includes effects of
1529         ! restarting even when restart uses a different timestep
1530         TYPE(WRFU_TimeInterval), INTENT(  OUT), OPTIONAL :: timeSinceSimulationStart
1531         ! minutes since simulation start date
1532         REAL,                    INTENT(  OUT), OPTIONAL :: minutesSinceSimulationStart
1533 ! <DESCRIPTION>
1534 ! This convenience routine returns clock information for domain grid in
1535 ! various forms.  The caller is responsible for ensuring that character
1536 ! string actual arguments are big enough.
1537 !
1538 ! </DESCRIPTION>
1539         ! Locals
1540         TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime, lcl_starttime
1541         TYPE(WRFU_Time) :: lcl_simulationStartTime
1542         TYPE(WRFU_TimeInterval) :: lcl_time_step, lcl_timeSinceSimulationStart
1543         INTEGER :: days, seconds, Sn, Sd, rc
1544         CHARACTER (LEN=256) :: tmp_str
1545         CHARACTER (LEN=256) :: frac_str
1546         REAL(WRFU_KIND_R8) :: currentDayOfYearR8
1547         IF ( PRESENT( start_time ) ) THEN
1548           start_time = domain_get_start_time ( grid )
1549         ENDIF
1550         IF ( PRESENT( start_timestr ) ) THEN
1551           lcl_starttime = domain_get_start_time ( grid )
1552           CALL wrf_timetoa ( lcl_starttime, start_timestr )
1553         ENDIF
1554         IF ( PRESENT( time_step ) ) THEN
1555           time_step = domain_get_time_step ( grid )
1556         ENDIF
1557         IF ( PRESENT( time_stepstr ) ) THEN
1558           lcl_time_step = domain_get_time_step ( grid )
1559           CALL WRFU_TimeIntervalGet( lcl_time_step, &
1560                                      timeString=time_stepstr, rc=rc )
1561           IF ( rc /= WRFU_SUCCESS ) THEN
1562             CALL wrf_error_fatal ( &
1563               'domain_clock_get:  WRFU_TimeIntervalGet() failed' )
1564           ENDIF
1565         ENDIF
1566         IF ( PRESENT( time_stepstr_frac ) ) THEN
1567           lcl_time_step = domain_get_time_step ( grid )
1568           CALL WRFU_TimeIntervalGet( lcl_time_step, timeString=tmp_str, &
1569                                      Sn=Sn, Sd=Sd, rc=rc )
1570           IF ( rc /= WRFU_SUCCESS ) THEN
1571             CALL wrf_error_fatal ( &
1572               'domain_clock_get:  WRFU_TimeIntervalGet() failed' )
1573           ENDIF
1574           CALL fraction_to_string( Sn, Sd, frac_str )
1575           time_stepstr_frac = TRIM(tmp_str)//TRIM(frac_str)
1576         ENDIF
1577         IF ( PRESENT( advanceCount ) ) THEN
1578           advanceCount = domain_get_advanceCount ( grid )
1579         ENDIF
1580         ! This duplication avoids assignment of time-manager objects
1581         ! which works now in ESMF 2.2.0 but may not work in the future
1582         ! if these objects become "deep".  We have already been bitten
1583         ! by this when the clock objects were changed from "shallow" to
1584         ! "deep".  Once again, adherence to orthodox canonical form by
1585         ! ESMF would avoid all this crap.
1586         IF ( PRESENT( current_time ) ) THEN
1587           current_time = domain_get_current_time ( grid )
1588         ENDIF
1589         IF ( PRESENT( current_timestr ) ) THEN
1590           lcl_currtime = domain_get_current_time ( grid )
1591           CALL wrf_timetoa ( lcl_currtime, current_timestr )
1592         ENDIF
1593         ! current time string including fractional part, if present
1594         IF ( PRESENT( current_timestr_frac ) ) THEN
1595           lcl_currtime = domain_get_current_time ( grid )
1596           CALL wrf_timetoa ( lcl_currtime, tmp_str )
1597           CALL WRFU_TimeGet( lcl_currtime, Sn=Sn, Sd=Sd, rc=rc )
1598           IF ( rc /= WRFU_SUCCESS ) THEN
1599             CALL wrf_error_fatal ( &
1600               'domain_clock_get:  WRFU_TimeGet() failed' )
1601           ENDIF
1602           CALL fraction_to_string( Sn, Sd, frac_str )
1603           current_timestr_frac = TRIM(tmp_str)//TRIM(frac_str)
1604         ENDIF
1605         IF ( PRESENT( stop_time ) ) THEN
1606           stop_time = domain_get_stop_time ( grid )
1607         ENDIF
1608         IF ( PRESENT( stop_timestr ) ) THEN
1609           lcl_stoptime = domain_get_stop_time ( grid )
1610           CALL wrf_timetoa ( lcl_stoptime, stop_timestr )
1611         ENDIF
1612         IF ( PRESENT( currentDayOfYearReal ) ) THEN
1613           lcl_currtime = domain_get_current_time ( grid )
1614           CALL WRFU_TimeGet( lcl_currtime, dayOfYear_r8=currentDayOfYearR8, &
1615                              rc=rc )
1616           IF ( rc /= WRFU_SUCCESS ) THEN
1617             CALL wrf_error_fatal ( &
1618                    'domain_clock_get:  WRFU_TimeGet(dayOfYear_r8) failed' )
1619           ENDIF
1620           currentDayOfYearReal = REAL( currentDayOfYearR8 ) - 1.0
1621         ENDIF
1622         IF ( PRESENT( simulationStartTime ) ) THEN
1623           simulationStartTime = domain_get_sim_start_time( grid )
1624         ENDIF
1625         IF ( PRESENT( simulationStartTimeStr ) ) THEN
1626           lcl_simulationStartTime = domain_get_sim_start_time( grid )
1627           CALL wrf_timetoa ( lcl_simulationStartTime, simulationStartTimeStr )
1628         ENDIF
1629         IF ( PRESENT( timeSinceSimulationStart ) ) THEN
1630           timeSinceSimulationStart = domain_get_time_since_sim_start( grid )
1631         ENDIF
1632         IF ( PRESENT( minutesSinceSimulationStart ) ) THEN
1633           lcl_timeSinceSimulationStart = domain_get_time_since_sim_start( grid )
1634           CALL WRFU_TimeIntervalGet( lcl_timeSinceSimulationStart, &
1635                                      D=days, S=seconds, Sn=Sn, Sd=Sd, rc=rc )
1636           IF ( rc /= WRFU_SUCCESS ) THEN
1637             CALL wrf_error_fatal ( &
1638                    'domain_clock_get:  WRFU_TimeIntervalGet() failed' )
1639           ENDIF
1640           ! get rid of hard-coded constants
1641           minutesSinceSimulationStart = ( REAL( days ) * 24. * 60. ) + &
1642                                         ( REAL( seconds ) / 60. )
1643           IF ( Sd /= 0 ) THEN
1644             minutesSinceSimulationStart = minutesSinceSimulationStart + &
1645                                           ( ( REAL( Sn ) / REAL( Sd ) ) / 60. )
1646           ENDIF
1647         ENDIF
1648         RETURN
1649       END SUBROUTINE domain_clock_get
1650
1651       FUNCTION domain_clockisstarttime ( grid ) RESULT ( is_start_time )
1652         IMPLICIT NONE
1653 ! <DESCRIPTION>
1654 ! This convenience function returns .TRUE. iff grid%clock is at its
1655 ! start time.
1656 !
1657 ! </DESCRIPTION>
1658         TYPE(domain), INTENT(IN) :: grid
1659         ! result
1660         LOGICAL :: is_start_time
1661         TYPE(WRFU_Time) :: start_time, current_time
1662         CALL domain_clock_get( grid, current_time=current_time, &
1663                                      start_time=start_time )
1664         is_start_time = ( current_time == start_time )
1665       END FUNCTION domain_clockisstarttime
1666
1667       FUNCTION domain_clockissimstarttime ( grid ) RESULT ( is_sim_start_time )
1668         IMPLICIT NONE
1669 ! <DESCRIPTION>
1670 ! This convenience function returns .TRUE. iff grid%clock is at the
1671 ! simulation start time.  (It returns .FALSE. during a restart run.)
1672 !
1673 ! </DESCRIPTION>
1674         TYPE(domain), INTENT(IN) :: grid
1675         ! result
1676         LOGICAL :: is_sim_start_time
1677         TYPE(WRFU_Time) :: simulationStartTime, current_time
1678         CALL domain_clock_get( grid, current_time=current_time, &
1679                                      simulationStartTime=simulationStartTime )
1680         is_sim_start_time = ( current_time == simulationStartTime )
1681       END FUNCTION domain_clockissimstarttime
1682
1683
1684
1685
1686       SUBROUTINE domain_clock_create( grid, StartTime, &
1687                                             StopTime,  &
1688                                             TimeStep )
1689         IMPLICIT NONE
1690         TYPE(domain),            INTENT(INOUT) :: grid
1691         TYPE(WRFU_Time),         INTENT(IN   ) :: StartTime
1692         TYPE(WRFU_Time),         INTENT(IN   ) :: StopTime
1693         TYPE(WRFU_TimeInterval), INTENT(IN   ) :: TimeStep
1694 ! <DESCRIPTION>
1695 ! This convenience routine creates the domain_clock for domain grid and
1696 ! sets associated flags.
1697 !
1698 ! </DESCRIPTION>
1699         ! Locals
1700         INTEGER :: rc
1701         grid%domain_clock = WRFU_ClockCreate( TimeStep= TimeStep,  &
1702                                               StartTime=StartTime, &
1703                                               StopTime= StopTime,  &
1704                                               rc=rc )
1705         IF ( rc /= WRFU_SUCCESS ) THEN
1706           CALL wrf_error_fatal ( &
1707             'domain_clock_create:  WRFU_ClockCreate() failed' )
1708         ENDIF
1709         grid%domain_clock_created = .TRUE.
1710         RETURN
1711       END SUBROUTINE domain_clock_create
1712
1713
1714
1715       SUBROUTINE domain_alarm_create( grid, alarm_id, interval, &
1716                                             begin_time, end_time )
1717         USE module_utility
1718         IMPLICIT NONE
1719         TYPE(domain), POINTER :: grid
1720         INTEGER, INTENT(IN) :: alarm_id
1721         TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: interval
1722         TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: begin_time
1723         TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: end_time
1724 ! <DESCRIPTION>
1725 ! This convenience routine creates alarm alarm_id for domain grid and
1726 ! sets associated flags.
1727 !
1728 ! </DESCRIPTION>
1729         ! Locals
1730         INTEGER :: rc
1731 !$$$ TBH:  Ideally, this could be simplified by passing all optional actual
1732 !$$$ TBH:  args into AlarmCreate.  However, since operations are performed on
1733 !$$$ TBH:  the actual args in-place in the calls, they must be present for the
1734 !$$$ TBH:  operations themselves to be defined.  Grrr...
1735         LOGICAL :: interval_only, all_args, no_args
1736         TYPE(WRFU_Time) :: startTime
1737         interval_only = .FALSE.
1738         all_args = .FALSE.
1739         no_args = .FALSE.
1740         IF ( ( .NOT. PRESENT( begin_time ) ) .AND. &
1741              ( .NOT. PRESENT( end_time   ) ) .AND. &
1742              (       PRESENT( interval   ) ) ) THEN
1743            interval_only = .TRUE.
1744         ELSE IF ( ( .NOT. PRESENT( begin_time ) ) .AND. &
1745                   ( .NOT. PRESENT( end_time   ) ) .AND. &
1746                   ( .NOT. PRESENT( interval   ) ) ) THEN
1747            no_args = .TRUE.
1748         ELSE IF ( (       PRESENT( begin_time ) ) .AND. &
1749                   (       PRESENT( end_time   ) ) .AND. &
1750                   (       PRESENT( interval   ) ) ) THEN
1751            all_args = .TRUE.
1752         ELSE
1753            CALL wrf_error_fatal ( &
1754              'ERROR in domain_alarm_create:  bad argument list' )
1755         ENDIF
1756         CALL domain_clock_get( grid, start_time=startTime )
1757         IF ( interval_only ) THEN
1758            grid%io_intervals( alarm_id ) = interval
1759            grid%alarms( alarm_id ) = &
1760              WRFU_AlarmCreate( clock=grid%domain_clock, &
1761                                RingInterval=interval,   &
1762                                rc=rc )
1763         ELSE IF ( no_args ) THEN
1764            grid%alarms( alarm_id ) = &
1765              WRFU_AlarmCreate( clock=grid%domain_clock, &
1766                                RingTime=startTime,      &
1767                                rc=rc )
1768         ELSE IF ( all_args ) THEN
1769            grid%io_intervals( alarm_id ) = interval
1770            grid%alarms( alarm_id ) = &
1771              WRFU_AlarmCreate( clock=grid%domain_clock,         &
1772                                RingTime=startTime + begin_time, &
1773                                RingInterval=interval,           &
1774                                StopTime=startTime + end_time,   &
1775                                rc=rc )
1776         ENDIF
1777         IF ( rc /= WRFU_SUCCESS ) THEN
1778           CALL wrf_error_fatal ( &
1779             'domain_alarm_create:  WRFU_AlarmCreate() failed' )
1780         ENDIF
1781         grid%alarms_created( alarm_id ) = .TRUE.
1782       END SUBROUTINE domain_alarm_create
1783
1784
1785
1786       SUBROUTINE domain_clock_set( grid, current_timestr, &
1787                                          stop_timestr,    &
1788                                          time_step_seconds )
1789         IMPLICIT NONE
1790         TYPE(domain),      INTENT(INOUT)           :: grid
1791         CHARACTER (LEN=*), INTENT(IN   ), OPTIONAL :: current_timestr
1792         CHARACTER (LEN=*), INTENT(IN   ), OPTIONAL :: stop_timestr
1793         INTEGER,           INTENT(IN   ), OPTIONAL :: time_step_seconds
1794 ! <DESCRIPTION>
1795 ! This convenience routine sets clock information for domain grid.
1796 ! The caller is responsible for ensuring that character string actual
1797 ! arguments are big enough.
1798 !
1799 ! </DESCRIPTION>
1800         ! Locals
1801         TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime
1802         TYPE(WRFU_TimeInterval) :: tmpTimeInterval
1803         INTEGER :: rc
1804         IF ( PRESENT( current_timestr ) ) THEN
1805           CALL wrf_atotime( current_timestr(1:19), lcl_currtime )
1806           CALL WRFU_ClockSet( grid%domain_clock, currTime=lcl_currtime, &
1807                               rc=rc )
1808           IF ( rc /= WRFU_SUCCESS ) THEN
1809             CALL wrf_error_fatal ( &
1810               'domain_clock_set:  WRFU_ClockSet(CurrTime) failed' )
1811           ENDIF
1812         ENDIF
1813         IF ( PRESENT( stop_timestr ) ) THEN
1814           CALL wrf_atotime( stop_timestr(1:19), lcl_stoptime )
1815           CALL WRFU_ClockSet( grid%domain_clock, stopTime=lcl_stoptime, &
1816                               rc=rc )
1817           IF ( rc /= WRFU_SUCCESS ) THEN
1818             CALL wrf_error_fatal ( &
1819               'domain_clock_set:  WRFU_ClockSet(StopTime) failed' )
1820           ENDIF
1821         ENDIF
1822         IF ( PRESENT( time_step_seconds ) ) THEN
1823           CALL WRFU_TimeIntervalSet( tmpTimeInterval, &
1824                                      S=time_step_seconds, rc=rc )
1825           IF ( rc /= WRFU_SUCCESS ) THEN
1826             CALL wrf_error_fatal ( &
1827               'domain_clock_set:  WRFU_TimeIntervalSet failed' )
1828           ENDIF
1829           CALL WRFU_ClockSet ( grid%domain_clock,        &
1830                                timeStep=tmpTimeInterval, &
1831                                rc=rc )
1832           IF ( rc /= WRFU_SUCCESS ) THEN
1833             CALL wrf_error_fatal ( &
1834               'domain_clock_set:  WRFU_ClockSet(TimeStep) failed' )
1835           ENDIF
1836         ENDIF
1837         RETURN
1838       END SUBROUTINE domain_clock_set
1839
1840
1841       ! Debug routine to print key clock information.
1842       ! Printed lines include pre_str.
1843       SUBROUTINE domain_clockprint ( level, grid, pre_str )
1844         IMPLICIT NONE
1845         INTEGER,           INTENT( IN) :: level
1846         TYPE(domain),      INTENT( IN) :: grid
1847         CHARACTER (LEN=*), INTENT( IN) :: pre_str
1848         CALL wrf_clockprint ( level, grid%domain_clock, pre_str )
1849         RETURN
1850       END SUBROUTINE domain_clockprint
1851
1852
1853       ! Advance the clock associated with grid.
1854       ! Also updates several derived time quantities in grid state.
1855       SUBROUTINE domain_clockadvance ( grid )
1856         IMPLICIT NONE
1857         TYPE(domain), INTENT(INOUT) :: grid
1858         INTEGER :: rc
1859         CALL domain_clockprint ( 250, grid, &
1860           'DEBUG domain_clockadvance():  before WRFU_ClockAdvance,' )
1861         CALL WRFU_ClockAdvance( grid%domain_clock, rc=rc )
1862         IF ( rc /= WRFU_SUCCESS ) THEN
1863           CALL wrf_error_fatal ( &
1864             'domain_clockadvance:  WRFU_ClockAdvance() failed' )
1865         ENDIF
1866         CALL domain_clockprint ( 250, grid, &
1867           'DEBUG domain_clockadvance():  after WRFU_ClockAdvance,' )
1868         ! Update derived time quantities in grid state.
1869         ! These are initialized in setup_timekeeping().
1870         CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime )
1871         CALL domain_clock_get( grid, currentDayOfYearReal=grid%julian )
1872         RETURN
1873       END SUBROUTINE domain_clockadvance
1874
1875
1876
1877       ! Set grid%gmt, grid%julday, and grid%julyr from simulation-start-date.
1878       ! Set start_of_simulation to TRUE iff current_time == simulation_start_time
1879       SUBROUTINE domain_setgmtetc ( grid, start_of_simulation )
1880         IMPLICIT NONE
1881         TYPE (domain), INTENT(INOUT) :: grid
1882         LOGICAL,       INTENT(  OUT) :: start_of_simulation
1883         ! locals
1884         CHARACTER (LEN=132)          :: message
1885         TYPE(WRFU_Time)              :: simStartTime
1886         INTEGER                      :: hr, mn, sec, ms, rc
1887         CALL domain_clockprint(150, grid, &
1888           'DEBUG domain_setgmtetc():  get simStartTime from clock,')
1889         CALL domain_clock_get( grid, simulationStartTime=simStartTime, &
1890                                      simulationStartTimeStr=message )
1891         CALL WRFU_TimeGet( simStartTime, YY=grid%julyr, dayOfYear=grid%julday, &
1892                            H=hr, M=mn, S=sec, MS=ms, rc=rc)
1893         IF ( rc /= WRFU_SUCCESS ) THEN
1894           CALL wrf_error_fatal ( &
1895             'domain_setgmtetc:  WRFU_TimeGet() failed' )
1896         ENDIF
1897         WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc():  simulation start time = [',TRIM( message ),']'
1898         CALL wrf_debug( 150, TRIM(wrf_err_message) )
1899         grid%gmt=hr+real(mn)/60.+real(sec)/3600.+real(ms)/(1000*3600)
1900         WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc():  julyr,hr,mn,sec,ms,julday = ', &
1901                                      grid%julyr,hr,mn,sec,ms,grid%julday
1902         CALL wrf_debug( 150, TRIM(wrf_err_message) )
1903         WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc():  gmt = ',grid%gmt
1904         CALL wrf_debug( 150, TRIM(wrf_err_message) )
1905         start_of_simulation = domain_ClockIsSimStartTime(grid)
1906         RETURN
1907       END SUBROUTINE domain_setgmtetc
1908
1909
1910
1911       ! Set pointer to current grid.
1912       ! To begin with, current grid is not set.
1913       SUBROUTINE set_current_grid_ptr( grid_ptr )
1914         IMPLICIT NONE
1915         TYPE(domain), POINTER :: grid_ptr
1916 !PRINT *,'DEBUG:  begin set_current_grid_ptr()'
1917 !IF ( ASSOCIATED( grid_ptr ) ) THEN
1918 !  PRINT *,'DEBUG:  set_current_grid_ptr():  current_grid is associated'
1919 !ELSE
1920 !  PRINT *,'DEBUG:  set_current_grid_ptr():  current_grid is NOT associated'
1921 !ENDIF
1922         current_grid_set = .TRUE.
1923         current_grid => grid_ptr
1924 !PRINT *,'DEBUG:  end set_current_grid_ptr()'
1925       END SUBROUTINE set_current_grid_ptr
1926
1927 !******************************************************************************
1928 ! BEGIN TEST SECTION
1929 !   Code in the test section is used to test domain methods.
1930 !   This code should probably be moved elsewhere, eventually.
1931 !******************************************************************************
1932
1933       ! Private utility routines for domain_time_test.
1934       SUBROUTINE domain_time_test_print ( pre_str, name_str, res_str )
1935         IMPLICIT NONE
1936         CHARACTER (LEN=*), INTENT(IN) :: pre_str
1937         CHARACTER (LEN=*), INTENT(IN) :: name_str
1938         CHARACTER (LEN=*), INTENT(IN) :: res_str
1939         CHARACTER (LEN=512) :: out_str
1940         WRITE (out_str,                                            &
1941           FMT="('DOMAIN_TIME_TEST ',A,':  ',A,' = ',A)") &
1942           TRIM(pre_str), TRIM(name_str), TRIM(res_str)
1943         CALL wrf_debug( 0, TRIM(out_str) )
1944       END SUBROUTINE domain_time_test_print
1945
1946       ! Test adjust_io_timestr
1947       SUBROUTINE test_adjust_io_timestr( TI_h, TI_m, TI_s, &
1948         CT_yy,  CT_mm,  CT_dd,  CT_h,  CT_m,  CT_s,        &
1949         ST_yy,  ST_mm,  ST_dd,  ST_h,  ST_m,  ST_s,        &
1950         res_str, testname )
1951         INTEGER, INTENT(IN) :: TI_H
1952         INTEGER, INTENT(IN) :: TI_M
1953         INTEGER, INTENT(IN) :: TI_S
1954         INTEGER, INTENT(IN) :: CT_YY
1955         INTEGER, INTENT(IN) :: CT_MM  ! month
1956         INTEGER, INTENT(IN) :: CT_DD  ! day of month
1957         INTEGER, INTENT(IN) :: CT_H
1958         INTEGER, INTENT(IN) :: CT_M
1959         INTEGER, INTENT(IN) :: CT_S
1960         INTEGER, INTENT(IN) :: ST_YY
1961         INTEGER, INTENT(IN) :: ST_MM  ! month
1962         INTEGER, INTENT(IN) :: ST_DD  ! day of month
1963         INTEGER, INTENT(IN) :: ST_H
1964         INTEGER, INTENT(IN) :: ST_M
1965         INTEGER, INTENT(IN) :: ST_S
1966         CHARACTER (LEN=*), INTENT(IN) :: res_str
1967         CHARACTER (LEN=*), INTENT(IN) :: testname
1968         ! locals
1969         TYPE(WRFU_TimeInterval) :: TI
1970         TYPE(WRFU_Time) :: CT, ST
1971         LOGICAL :: test_passed
1972         INTEGER :: rc
1973         CHARACTER(LEN=WRFU_MAXSTR) :: TI_str, CT_str, ST_str, computed_str
1974         ! TI
1975         CALL WRFU_TimeIntervalSet( TI, H=TI_H, M=TI_M, S=TI_S, rc=rc )
1976         CALL wrf_check_error( WRFU_SUCCESS, rc, &
1977                               'FAIL:  '//TRIM(testname)//'WRFU_TimeIntervalSet() ', &
1978                               __FILE__ , &
1979                               __LINE__  )
1980         CALL WRFU_TimeIntervalGet( TI, timeString=TI_str, rc=rc )
1981         CALL wrf_check_error( WRFU_SUCCESS, rc, &
1982                               'FAIL:  '//TRIM(testname)//'WRFU_TimeGet() ', &
1983                               __FILE__ , &
1984                               __LINE__  )
1985         ! CT
1986         CALL WRFU_TimeSet( CT, YY=CT_YY, MM=CT_MM, DD=CT_DD , &
1987                                 H=CT_H,   M=CT_M,   S=CT_S, rc=rc )
1988         CALL wrf_check_error( WRFU_SUCCESS, rc, &
1989                               'FAIL:  '//TRIM(testname)//'WRFU_TimeSet() ', &
1990                               __FILE__ , &
1991                               __LINE__  )
1992         CALL WRFU_TimeGet( CT, timeString=CT_str, rc=rc )
1993         CALL wrf_check_error( WRFU_SUCCESS, rc, &
1994                               'FAIL:  '//TRIM(testname)//'WRFU_TimeGet() ', &
1995                               __FILE__ , &
1996                               __LINE__  )
1997         ! ST
1998         CALL WRFU_TimeSet( ST, YY=ST_YY, MM=ST_MM, DD=ST_DD , &
1999                                 H=ST_H,   M=ST_M,   S=ST_S, rc=rc )
2000         CALL wrf_check_error( WRFU_SUCCESS, rc, &
2001                               'FAIL:  '//TRIM(testname)//'WRFU_TimeSet() ', &
2002                               __FILE__ , &
2003                               __LINE__  )
2004         CALL WRFU_TimeGet( ST, timeString=ST_str, rc=rc )
2005         CALL wrf_check_error( WRFU_SUCCESS, rc, &
2006                               'FAIL:  '//TRIM(testname)//'WRFU_TimeGet() ', &
2007                               __FILE__ , &
2008                               __LINE__  )
2009         ! Test
2010         CALL adjust_io_timestr ( TI, CT, ST, computed_str )
2011         ! check result
2012         test_passed = .FALSE.
2013         IF ( LEN_TRIM(res_str) == LEN_TRIM(computed_str) ) THEN
2014           IF ( res_str(1:LEN_TRIM(res_str)) == computed_str(1:LEN_TRIM(computed_str)) ) THEN
2015             test_passed = .TRUE.
2016           ENDIF
2017         ENDIF
2018         ! print result
2019         IF ( test_passed ) THEN
2020           WRITE(*,FMT='(A)') 'PASS:  '//TRIM(testname)
2021         ELSE
2022           WRITE(*,*) 'FAIL:  ',TRIM(testname),':  adjust_io_timestr(',    &
2023             TRIM(TI_str),',',TRIM(CT_str),',',TRIM(ST_str),')  expected <', &
2024             TRIM(res_str),'>  but computed <',TRIM(computed_str),'>'
2025         ENDIF
2026       END SUBROUTINE test_adjust_io_timestr
2027
2028       ! Print lots of time-related information for testing and debugging.
2029       ! Printed lines include pre_str and special string DOMAIN_TIME_TEST
2030       ! suitable for grepping by test scripts.
2031       ! Returns immediately unless self_test_domain has been set to .true. in
2032       ! namelist /time_control/ .
2033       SUBROUTINE domain_time_test ( grid, pre_str )
2034         IMPLICIT NONE
2035         TYPE(domain),      INTENT(IN) :: grid
2036         CHARACTER (LEN=*), INTENT(IN) :: pre_str
2037         ! locals
2038         LOGICAL, SAVE :: one_time_tests_done = .FALSE.
2039         REAL :: minutesSinceSimulationStart
2040         INTEGER :: advance_count, rc
2041         REAL :: currentDayOfYearReal
2042         TYPE(WRFU_TimeInterval) :: timeSinceSimulationStart
2043         TYPE(WRFU_Time) :: simulationStartTime
2044         CHARACTER (LEN=512) :: res_str
2045         LOGICAL :: self_test_domain
2046         !
2047         ! NOTE:  test_adjust_io_timestr() (see below) is a self-test that
2048         !        prints PASS/FAIL/ERROR messages in a standard format.  All
2049         !        of the other tests should be strucutred the same way,
2050         !        someday.
2051         !
2052         CALL nl_get_self_test_domain( 1, self_test_domain )
2053         IF ( self_test_domain ) THEN
2054           CALL domain_clock_get( grid, advanceCount=advance_count )
2055           WRITE ( res_str, FMT="(I8.8)" ) advance_count
2056           CALL domain_time_test_print( pre_str, 'advanceCount', res_str )
2057           CALL domain_clock_get( grid, currentDayOfYearReal=currentDayOfYearReal )
2058           WRITE ( res_str, FMT='(F10.6)' ) currentDayOfYearReal
2059           CALL domain_time_test_print( pre_str, 'currentDayOfYearReal', res_str )
2060           CALL domain_clock_get( grid, minutesSinceSimulationStart=minutesSinceSimulationStart )
2061           WRITE ( res_str, FMT='(F10.6)' ) minutesSinceSimulationStart
2062           CALL domain_time_test_print( pre_str, 'minutesSinceSimulationStart', res_str )
2063           CALL domain_clock_get( grid, current_timestr=res_str )
2064           CALL domain_time_test_print( pre_str, 'current_timestr', res_str )
2065           CALL domain_clock_get( grid, current_timestr_frac=res_str )
2066           CALL domain_time_test_print( pre_str, 'current_timestr_frac', res_str )
2067           CALL domain_clock_get( grid, timeSinceSimulationStart=timeSinceSimulationStart )
2068           CALL WRFU_TimeIntervalGet( timeSinceSimulationStart, timeString=res_str, rc=rc )
2069           IF ( rc /= WRFU_SUCCESS ) THEN
2070             CALL wrf_error_fatal ( &
2071               'domain_time_test:  WRFU_TimeIntervalGet() failed' )
2072           ENDIF
2073           CALL domain_time_test_print( pre_str, 'timeSinceSimulationStart', res_str )
2074           ! The following tests should only be done once, the first time this
2075           ! routine is called.
2076           IF ( .NOT. one_time_tests_done ) THEN
2077             one_time_tests_done = .TRUE.
2078             CALL domain_clock_get( grid, simulationStartTimeStr=res_str )
2079             CALL domain_time_test_print( pre_str, 'simulationStartTime', res_str )
2080             CALL domain_clock_get( grid, start_timestr=res_str )
2081             CALL domain_time_test_print( pre_str, 'start_timestr', res_str )
2082             CALL domain_clock_get( grid, stop_timestr=res_str )
2083             CALL domain_time_test_print( pre_str, 'stop_timestr', res_str )
2084             CALL domain_clock_get( grid, time_stepstr=res_str )
2085             CALL domain_time_test_print( pre_str, 'time_stepstr', res_str )
2086             CALL domain_clock_get( grid, time_stepstr_frac=res_str )
2087             CALL domain_time_test_print( pre_str, 'time_stepstr_frac', res_str )
2088             ! Test adjust_io_timestr()
2089             !     CT = 2000-01-26_00:00:00   (current time)
2090             !     ST = 2000-01-24_12:00:00   (start time)
2091             !     TI = 00000_03:00:00        (time interval)
2092             ! the resulting time string should be:
2093             !     2000-01-26_00:00:00
2094             CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0,          &
2095               CT_yy=2000,  CT_mm=1,  CT_dd=26,  CT_h=0,  CT_m=0,  CT_s=0, &
2096               ST_yy=2000,  ST_mm=1,  ST_dd=24,  ST_h=12, ST_m=0,  ST_s=0, &
2097               res_str='2000-01-26_00:00:00', testname='adjust_io_timestr_1' )
2098             ! this should fail (and does)
2099             !  CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0,          &
2100             !    CT_yy=2000,  CT_mm=1,  CT_dd=26,  CT_h=0,  CT_m=0,  CT_s=0, &
2101             !    ST_yy=2000,  ST_mm=1,  ST_dd=24,  ST_h=12, ST_m=0,  ST_s=0, &
2102             !    res_str='2000-01-26_00:00:01', testname='adjust_io_timestr_FAIL1' )
2103           ENDIF
2104         ENDIF
2105         RETURN
2106       END SUBROUTINE domain_time_test
2107
2108 !******************************************************************************
2109 ! END TEST SECTION
2110 !******************************************************************************
2111
2112
2113 END MODULE module_domain
2114
2115
2116 ! The following routines are outside this module to avoid build dependences.
2117
2118
2119 ! Get current time as a string (current time from clock attached to the
2120 ! current_grid).  Includes fractional part, if present.
2121 ! Returns empty string if current_grid is not set or if timing has not yet
2122 ! been set up on current_grid.
2123 SUBROUTINE get_current_time_string( time_str )
2124   USE module_domain
2125   IMPLICIT NONE
2126   CHARACTER (LEN=*), INTENT(OUT) :: time_str
2127   ! locals
2128   INTEGER :: debug_level_lcl
2129 !PRINT *,'DEBUG:  begin get_current_time_string()'
2130   time_str = ''
2131   IF ( current_grid_set ) THEN
2132 !$$$DEBUG
2133 !PRINT *,'DEBUG:  get_current_time_string():  checking association of current_grid...'
2134 !IF ( ASSOCIATED( current_grid ) ) THEN
2135 !  PRINT *,'DEBUG:  get_current_time_string():  current_grid is associated'
2136 !ELSE
2137 !  PRINT *,'DEBUG:  get_current_time_string():  current_grid is NOT associated'
2138 !ENDIF
2139 !$$$END DEBUG
2140     IF ( current_grid%time_set ) THEN
2141 !PRINT *,'DEBUG:  get_current_time_string():  calling domain_clock_get()'
2142       ! set debug_level to zero and clear current_grid_set to avoid recursion
2143       CALL get_wrf_debug_level( debug_level_lcl )
2144       CALL set_wrf_debug_level ( 0 )
2145       current_grid_set = .FALSE.
2146       CALL domain_clock_get( current_grid, current_timestr_frac=time_str )
2147       ! restore debug_level and current_grid_set
2148       CALL set_wrf_debug_level ( debug_level_lcl )
2149       current_grid_set = .TRUE.
2150 !PRINT *,'DEBUG:  get_current_time_string():  back from domain_clock_get()'
2151     ENDIF
2152   ENDIF
2153 !PRINT *,'DEBUG:  end get_current_time_string()'
2154 END SUBROUTINE get_current_time_string
2155
2156
2157 ! Get current domain name as a string of form "d<NN>" where "<NN>" is
2158 ! grid%id printed in two characters, with leading zero if needed ("d01",
2159 ! "d02", etc.).
2160 ! Return empty string if current_grid not set.
2161 SUBROUTINE get_current_grid_name( grid_str )
2162   USE module_domain
2163   IMPLICIT NONE
2164   CHARACTER (LEN=*), INTENT(OUT) :: grid_str
2165   grid_str = ''
2166   IF ( current_grid_set ) THEN
2167     WRITE(grid_str,FMT="('d',I2.2)") current_grid%id
2168   ENDIF
2169 END SUBROUTINE get_current_grid_name
2170
2171
2172