frame/module_domain.F

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