PageRenderTime 52ms CodeModel.GetById 0ms RepoModel.GetById 0ms app.codeStats 1ms

/wrfv2_fire/frame/module_domain.F

https://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 2991 lines | 1853 code | 300 blank | 838 comment | 9 complexity | 53f37e7c7f8d2d3bdfec4dc967189278 MD5 | raw file
Possible License(s): AGPL-1.0 
    

  1. !WRF:DRIVER_LAYER:DOMAIN_OBJECT
    2. 

  2. !
    3. 

  3. !  Following are the routines contained within this MODULE:
    4. 

  4. 

  5. !  alloc_and_configure_domain        1. Allocate the space for a single domain (constants
    6. 

  6. !                                       and null terminate pointers).
    7. 

  7. !                                    2. Connect the domains as a linked list.
    8. 

  8. !                                    3. Store all of the domain constants.
    9. 

  9. !                                    4. CALL alloc_space_field.
    10. 

  10. 

  11. !  alloc_space_field                 1. Allocate space for the gridded data required for
    12. 

  12. !                                       each domain.
    13. 

  13. 

  14. !  dealloc_space_domain              1. Reconnect linked list nodes since the current
    15. 

  15. !                                       node is removed.
    16. 

  16. !                                    2. CALL dealloc_space_field.
    17. 

  17. !                                    3. Deallocate single domain.
    18. 

  18. 

  19. !  dealloc_space_field               1. Deallocate each of the fields for a particular
    20. 

  20. !                                       domain.
    21. 

  21. 

  22. !  first_loc_integer                 1. Find the first incidence of a particular
    23. 

  23. !                                       domain identifier from an array of domain
    24. 

  24. !                                       identifiers.
    25. 

  25. 

  26. MODULE module_domain
    27. 

  27. 

  28.    USE module_driver_constants
    29. 

  29.    USE module_machine
    30. 

  30.    USE module_configure
    31. 

  31.    USE module_wrf_error
    32. 

  32.    USE module_utility
    33. 

  33.    USE module_domain_type
    34. 

  34. 

  35.    ! In WRFV3, the module_domain_type is defined
    36. 

  36.    ! in a separaate source file, frame/module_domain_type.F
    37. 

  37.    ! This enables splitting off the alloc_space_field routine
    38. 

  38.    ! into a separate file, reducing the size of module_domain
    39. 

  39. 

  40.    !  Now that a "domain" TYPE exists, we can use it to store a few pointers
    41. 

  41.    !  to this type.  These are primarily for use in traversing the linked list.
    42. 

  42.    !  The "head_grid" is always the pointer to the first domain that is
    43. 

  43.    !  allocated.  This is available and is not to be changed.  The others are
    44. 

  44.    !  just temporary pointers.
    45. 

  45. 

  46.    TYPE(domain) , POINTER :: head_grid , new_grid , next_grid , old_grid
    47. 

  47. 

  48.    !  To facilitate an easy integration of each of the domains that are on the
    49. 

  49.    !  same level, we have an array for the head pointer for each level.  This
    50. 

  50.    !  removed the need to search through the linked list at each time step to
    51. 

  51.    !  find which domains are to be active.
    52. 

  52. 

  53.    TYPE domain_levels
    54. 

  54.       TYPE(domain) , POINTER                              :: first_domain
    55. 

  55.    END TYPE domain_levels
    56. 

  56. 

  57.    TYPE(domain_levels) , DIMENSION(max_levels)            :: head_for_each_level
    58. 

  58. 

  59.    ! Use this to support debugging features, giving easy access to clock, etc.  
    60. 

  60.    TYPE(domain), POINTER :: current_grid
    61. 

  61.    LOGICAL, SAVE :: current_grid_set = .FALSE.
    62. 

  62. 

  63.    ! internal routines
    64. 

  64.    PRIVATE domain_time_test_print
    65. 

  65.    PRIVATE test_adjust_io_timestr
    66. 

  66. 

  67.    INTERFACE get_ijk_from_grid
    68. 

  68.      MODULE PROCEDURE get_ijk_from_grid1, get_ijk_from_grid2
    69. 

  69.    END INTERFACE
    70. 

  70. 

  71.    INTEGER, PARAMETER :: max_hst_mods = 200
    72. 

  72. 

  73. CONTAINS
    74. 

  74. 

  75.    SUBROUTINE adjust_domain_dims_for_move( grid , dx, dy )
    76. 

  76.     IMPLICIT NONE
    77. 

  77. 

  78.     TYPE( domain ), POINTER   :: grid
    79. 

  79.     INTEGER, INTENT(IN) ::  dx, dy
    80. 

  80. 

  81.     data_ordering : SELECT CASE ( model_data_order )
    82. 

  82.        CASE  ( DATA_ORDER_XYZ )
    83. 

  83.             grid%sm31  = grid%sm31 + dx
    84. 

  84.             grid%em31  = grid%em31 + dx
    85. 

  85.             grid%sm32  = grid%sm32 + dy
    86. 

  86.             grid%em32  = grid%em32 + dy
    87. 

  87.             grid%sp31  = grid%sp31 + dx
    88. 

  88.             grid%ep31  = grid%ep31 + dx
    89. 

  89.             grid%sp32  = grid%sp32 + dy
    90. 

  90.             grid%ep32  = grid%ep32 + dy
    91. 

  91.             grid%sd31  = grid%sd31 + dx
    92. 

  92.             grid%ed31  = grid%ed31 + dx
    93. 

  93.             grid%sd32  = grid%sd32 + dy
    94. 

  94.             grid%ed32  = grid%ed32 + dy
    95. 

  95. 

  96.        CASE  ( DATA_ORDER_YXZ )
    97. 

  97.             grid%sm31  = grid%sm31 + dy
    98. 

  98.             grid%em31  = grid%em31 + dy
    99. 

  99.             grid%sm32  = grid%sm32 + dx
    100. 

  100.             grid%em32  = grid%em32 + dx
    101. 

  101.             grid%sp31  = grid%sp31 + dy
    102. 

  102.             grid%ep31  = grid%ep31 + dy
    103. 

  103.             grid%sp32  = grid%sp32 + dx
    104. 

  104.             grid%ep32  = grid%ep32 + dx
    105. 

  105.             grid%sd31  = grid%sd31 + dy
    106. 

  106.             grid%ed31  = grid%ed31 + dy
    107. 

  107.             grid%sd32  = grid%sd32 + dx
    108. 

  108.             grid%ed32  = grid%ed32 + dx
    109. 

  109. 

  110.        CASE  ( DATA_ORDER_ZXY )
    111. 

  111.             grid%sm32  = grid%sm32 + dx
    112. 

  112.             grid%em32  = grid%em32 + dx
    113. 

  113.             grid%sm33  = grid%sm33 + dy
    114. 

  114.             grid%em33  = grid%em33 + dy
    115. 

  115.             grid%sp32  = grid%sp32 + dx
    116. 

  116.             grid%ep32  = grid%ep32 + dx
    117. 

  117.             grid%sp33  = grid%sp33 + dy
    118. 

  118.             grid%ep33  = grid%ep33 + dy
    119. 

  119.             grid%sd32  = grid%sd32 + dx
    120. 

  120.             grid%ed32  = grid%ed32 + dx
    121. 

  121.             grid%sd33  = grid%sd33 + dy
    122. 

  122.             grid%ed33  = grid%ed33 + dy
    123. 

  123. 

  124.        CASE  ( DATA_ORDER_ZYX )
    125. 

  125.             grid%sm32  = grid%sm32 + dy
    126. 

  126.             grid%em32  = grid%em32 + dy
    127. 

  127.             grid%sm33  = grid%sm33 + dx
    128. 

  128.             grid%em33  = grid%em33 + dx
    129. 

  129.             grid%sp32  = grid%sp32 + dy
    130. 

  130.             grid%ep32  = grid%ep32 + dy
    131. 

  131.             grid%sp33  = grid%sp33 + dx
    132. 

  132.             grid%ep33  = grid%ep33 + dx
    133. 

  133.             grid%sd32  = grid%sd32 + dy
    134. 

  134.             grid%ed32  = grid%ed32 + dy
    135. 

  135.             grid%sd33  = grid%sd33 + dx
    136. 

  136.             grid%ed33  = grid%ed33 + dx
    137. 

  137. 

  138.        CASE  ( DATA_ORDER_XZY )
    139. 

  139.             grid%sm31  = grid%sm31 + dx
    140. 

  140.             grid%em31  = grid%em31 + dx
    141. 

  141.             grid%sm33  = grid%sm33 + dy
    142. 

  142.             grid%em33  = grid%em33 + dy
    143. 

  143.             grid%sp31  = grid%sp31 + dx
    144. 

  144.             grid%ep31  = grid%ep31 + dx
    145. 

  145.             grid%sp33  = grid%sp33 + dy
    146. 

  146.             grid%ep33  = grid%ep33 + dy
    147. 

  147.             grid%sd31  = grid%sd31 + dx
    148. 

  148.             grid%ed31  = grid%ed31 + dx
    149. 

  149.             grid%sd33  = grid%sd33 + dy
    150. 

  150.             grid%ed33  = grid%ed33 + dy
    151. 

  151. 

  152.        CASE  ( DATA_ORDER_YZX )
    153. 

  153.             grid%sm31  = grid%sm31 + dy
    154. 

  154.             grid%em31  = grid%em31 + dy
    155. 

  155.             grid%sm33  = grid%sm33 + dx
    156. 

  156.             grid%em33  = grid%em33 + dx
    157. 

  157.             grid%sp31  = grid%sp31 + dy
    158. 

  158.             grid%ep31  = grid%ep31 + dy
    159. 

  159.             grid%sp33  = grid%sp33 + dx
    160. 

  160.             grid%ep33  = grid%ep33 + dx
    161. 

  161.             grid%sd31  = grid%sd31 + dy
    162. 

  162.             grid%ed31  = grid%ed31 + dy
    163. 

  163.             grid%sd33  = grid%sd33 + dx
    164. 

  164.             grid%ed33  = grid%ed33 + dx
    165. 

  165. 

  166.     END SELECT data_ordering
    167. 

  167. 

  168. #if 0
    169. 

  169.     CALL dealloc_space_field ( grid )
    170. 

  170. 

  171.     CALL alloc_space_field ( grid, grid%id , 1 , 2 , .FALSE. ,     &
    172. 

  172.                              grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
    173. 

  173.                              grid%sm31,  grid%em31,  grid%sm32,  grid%em32,  grid%sm33,  grid%em33, &
    174. 

  174.                              grid%sp31,  grid%ep31,  grid%sp32,  grid%ep32,  grid%sp33,  grid%ep33, &
    175. 

  175.                              grid%sp31x, grid%ep31x, grid%sp32x, grid%ep32x, grid%sp33x, grid%ep33x, &
    176. 

  176.                              grid%sp31y, grid%ep31y, grid%sp32y, grid%ep32y, grid%sp33y, grid%ep33y, &
    177. 

  177.                              grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, &   ! x-xpose
    178. 

  178.                              grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y  &   ! y-xpose
    179. 

  179.       )
    180. 

  180. #endif
    181. 

  181. 

  182.     RETURN
    183. 

  183.    END SUBROUTINE adjust_domain_dims_for_move
    184. 

  184. 

  185. #if 1
    186. 

  186.    SUBROUTINE get_ijk_from_grid1 (  grid ,                   &
    187. 

  187.                            ids, ide, jds, jde, kds, kde,    &
    188. 

  188.                            ims, ime, jms, jme, kms, kme,    &
    189. 

  189.                            ips, ipe, jps, jpe, kps, kpe,    &
    190. 

  190.                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
    191. 

  191.                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
    192. 

  192.                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
    193. 

  193.                            ipsy, ipey, jpsy, jpey, kpsy, kpey )
    194. 

  194.     IMPLICIT NONE
    195. 

  195.     TYPE( domain ), INTENT (IN)  :: grid
    196. 

  196.     INTEGER, INTENT(OUT) ::                                 &
    197. 

  197.                            ids, ide, jds, jde, kds, kde,    &
    198. 

  198.                            ims, ime, jms, jme, kms, kme,    &
    199. 

  199.                            ips, ipe, jps, jpe, kps, kpe,    &
    200. 

  200.                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
    201. 

  201.                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
    202. 

  202.                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
    203. 

  203.                            ipsy, ipey, jpsy, jpey, kpsy, kpey
    204. 

  204. 

  205.      CALL get_ijk_from_grid2 (  grid ,                   &
    206. 

  206.                            ids, ide, jds, jde, kds, kde,    &
    207. 

  207.                            ims, ime, jms, jme, kms, kme,    &
    208. 

  208.                            ips, ipe, jps, jpe, kps, kpe )
    209. 

  209.      data_ordering : SELECT CASE ( model_data_order )
    210. 

  210.        CASE  ( DATA_ORDER_XYZ )
    211. 

  211.            imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
    212. 

  212.            ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
    213. 

  213.            imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
    214. 

  214.            ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
    215. 

  215.        CASE  ( DATA_ORDER_YXZ )
    216. 

  216.            imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
    217. 

  217.            ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
    218. 

  218.            imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
    219. 

  219.            ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
    220. 

  220.        CASE  ( DATA_ORDER_ZXY )
    221. 

  221.            imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
    222. 

  222.            ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
    223. 

  223.            imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
    224. 

  224.            ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
    225. 

  225.        CASE  ( DATA_ORDER_ZYX )
    226. 

  226.            imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
    227. 

  227.            ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
    228. 

  228.            imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
    229. 

  229.            ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
    230. 

  230.        CASE  ( DATA_ORDER_XZY )
    231. 

  231.            imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
    232. 

  232.            ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
    233. 

  233.            imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
    234. 

  234.            ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
    235. 

  235.        CASE  ( DATA_ORDER_YZX )
    236. 

  236.            imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
    237. 

  237.            ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
    238. 

  238.            imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
    239. 

  239.            ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
    240. 

  240.      END SELECT data_ordering
    241. 

  241.    END SUBROUTINE get_ijk_from_grid1
    242. 

  242. 

  243.    SUBROUTINE get_ijk_from_grid2 (  grid ,                   &
    244. 

  244.                            ids, ide, jds, jde, kds, kde,    &
    245. 

  245.                            ims, ime, jms, jme, kms, kme,    &
    246. 

  246.                            ips, ipe, jps, jpe, kps, kpe )
    247. 

  247. 

  248.     IMPLICIT NONE
    249. 

  249. 

  250.     TYPE( domain ), INTENT (IN)  :: grid
    251. 

  251.     INTEGER, INTENT(OUT) ::                                 &
    252. 

  252.                            ids, ide, jds, jde, kds, kde,    &
    253. 

  253.                            ims, ime, jms, jme, kms, kme,    &
    254. 

  254.                            ips, ipe, jps, jpe, kps, kpe
    255. 

  255. 

  256.     data_ordering : SELECT CASE ( model_data_order )
    257. 

  257.        CASE  ( DATA_ORDER_XYZ )
    258. 

  258.            ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd33 ; kde = grid%ed33 ;
    259. 

  259.            ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm33 ; kme = grid%em33 ;
    260. 

  260.            ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp33 ; kpe = grid%ep33 ; 
    261. 

  261.        CASE  ( DATA_ORDER_YXZ )
    262. 

  262.            ids = grid%sd32  ; ide = grid%ed32  ; jds = grid%sd31  ; jde = grid%ed31  ; kds = grid%sd33  ; kde = grid%ed33  ; 
    263. 

  263.            ims = grid%sm32  ; ime = grid%em32  ; jms = grid%sm31  ; jme = grid%em31  ; kms = grid%sm33  ; kme = grid%em33  ; 
    264. 

  264.            ips = grid%sp32  ; ipe = grid%ep32  ; jps = grid%sp31  ; jpe = grid%ep31  ; kps = grid%sp33  ; kpe = grid%ep33  ; 
    265. 

  265.        CASE  ( DATA_ORDER_ZXY )
    266. 

  266.            ids = grid%sd32  ; ide = grid%ed32  ; jds = grid%sd33  ; jde = grid%ed33  ; kds = grid%sd31  ; kde = grid%ed31  ; 
    267. 

  267.            ims = grid%sm32  ; ime = grid%em32  ; jms = grid%sm33  ; jme = grid%em33  ; kms = grid%sm31  ; kme = grid%em31  ; 
    268. 

  268.            ips = grid%sp32  ; ipe = grid%ep32  ; jps = grid%sp33  ; jpe = grid%ep33  ; kps = grid%sp31  ; kpe = grid%ep31  ; 
    269. 

  269.        CASE  ( DATA_ORDER_ZYX )
    270. 

  270.            ids = grid%sd33  ; ide = grid%ed33  ; jds = grid%sd32  ; jde = grid%ed32  ; kds = grid%sd31  ; kde = grid%ed31  ; 
    271. 

  271.            ims = grid%sm33  ; ime = grid%em33  ; jms = grid%sm32  ; jme = grid%em32  ; kms = grid%sm31  ; kme = grid%em31  ; 
    272. 

  272.            ips = grid%sp33  ; ipe = grid%ep33  ; jps = grid%sp32  ; jpe = grid%ep32  ; kps = grid%sp31  ; kpe = grid%ep31  ; 
    273. 

  273.        CASE  ( DATA_ORDER_XZY )
    274. 

  274.            ids = grid%sd31  ; ide = grid%ed31  ; jds = grid%sd33  ; jde = grid%ed33  ; kds = grid%sd32  ; kde = grid%ed32  ; 
    275. 

  275.            ims = grid%sm31  ; ime = grid%em31  ; jms = grid%sm33  ; jme = grid%em33  ; kms = grid%sm32  ; kme = grid%em32  ; 
    276. 

  276.            ips = grid%sp31  ; ipe = grid%ep31  ; jps = grid%sp33  ; jpe = grid%ep33  ; kps = grid%sp32  ; kpe = grid%ep32  ; 
    277. 

  277.        CASE  ( DATA_ORDER_YZX )
    278. 

  278.            ids = grid%sd33  ; ide = grid%ed33  ; jds = grid%sd31  ; jde = grid%ed31  ; kds = grid%sd32  ; kde = grid%ed32  ; 
    279. 

  279.            ims = grid%sm33  ; ime = grid%em33  ; jms = grid%sm31  ; jme = grid%em31  ; kms = grid%sm32  ; kme = grid%em32  ; 
    280. 

  280.            ips = grid%sp33  ; ipe = grid%ep33  ; jps = grid%sp31  ; jpe = grid%ep31  ; kps = grid%sp32  ; kpe = grid%ep32  ; 
    281. 

  281.     END SELECT data_ordering
    282. 

  282.    END SUBROUTINE get_ijk_from_grid2
    283. 

  283. 

  284. ! return the values for subgrid whose refinement is in grid%sr
    285. 

  285. ! note when using this routine, it does not affect K. For K 
    286. 

  286. ! (vertical), it just returns what get_ijk_from_grid does
    287. 

  287.    SUBROUTINE get_ijk_from_subgrid (  grid ,                &
    288. 

  288.                            ids0, ide0, jds0, jde0, kds0, kde0,    &
    289. 

  289.                            ims0, ime0, jms0, jme0, kms0, kme0,    &
    290. 

  290.                            ips0, ipe0, jps0, jpe0, kps0, kpe0    )
    291. 

  291.     TYPE( domain ), INTENT (IN)  :: grid
    292. 

  292.     INTEGER, INTENT(OUT) ::                                 &
    293. 

  293.                            ids0, ide0, jds0, jde0, kds0, kde0,    &
    294. 

  294.                            ims0, ime0, jms0, jme0, kms0, kme0,    &
    295. 

  295.                            ips0, ipe0, jps0, jpe0, kps0, kpe0
    296. 

  296.    ! Local
    297. 

  297.     INTEGER              ::                                 &
    298. 

  298.                            ids, ide, jds, jde, kds, kde,    &
    299. 

  299.                            ims, ime, jms, jme, kms, kme,    &
    300. 

  300.                            ips, ipe, jps, jpe, kps, kpe
    301. 

  301.      CALL get_ijk_from_grid (  grid ,                         &
    302. 

  302.                              ids, ide, jds, jde, kds, kde,    &
    303. 

  303.                              ims, ime, jms, jme, kms, kme,    &
    304. 

  304.                              ips, ipe, jps, jpe, kps, kpe    )
    305. 

  305.      ids0 = ids
    306. 

  306.      ide0 = ide * grid%sr_x
    307. 

  307.      ims0 = (ims-1)*grid%sr_x+1
    308. 

  308.      ime0 = ime * grid%sr_x
    309. 

  309.      ips0 = (ips-1)*grid%sr_x+1
    310. 

  310.      ipe0 = ipe * grid%sr_x
    311. 

  311. 

  312.      jds0 = jds
    313. 

  313.      jde0 = jde * grid%sr_y
    314. 

  314.      jms0 = (jms-1)*grid%sr_y+1
    315. 

  315.      jme0 = jme * grid%sr_y
    316. 

  316.      jps0 = (jps-1)*grid%sr_y+1
    317. 

  317.      jpe0 = jpe * grid%sr_y
    318. 

  318. 

  319.      kds0 = kds
    320. 

  320.      kde0 = kde
    321. 

  321.      kms0 = kms
    322. 

  322.      kme0 = kme
    323. 

  323.      kps0 = kps
    324. 

  324.      kpe0 = kpe
    325. 

  325.    RETURN
    326. 

  326.    END SUBROUTINE get_ijk_from_subgrid
    327. 

  327. #endif
    328. 

  328. 

  329. 

  330. ! Default version ; Otherwise module containing interface to DM library will provide
    331. 

  331. 

  332.    SUBROUTINE wrf_patch_domain( id , domdesc , parent, parent_id , parent_domdesc , &
    333. 

  333.                             sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
    334. 

  334.                             sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
    335. 

  335.                             sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
    336. 

  336.                                         sp1x , ep1x , sm1x , em1x , &
    337. 

  337.                                         sp2x , ep2x , sm2x , em2x , &
    338. 

  338.                                         sp3x , ep3x , sm3x , em3x , &
    339. 

  339.                                         sp1y , ep1y , sm1y , em1y , &
    340. 

  340.                                         sp2y , ep2y , sm2y , em2y , &
    341. 

  341.                                         sp3y , ep3y , sm3y , em3y , &
    342. 

  342.                             bdx , bdy , bdy_mask )
    343. 

  343. !<DESCRIPTION>
    344. 

  344. ! Wrf_patch_domain is called as part of the process of initiating a new
    345. 

  345. ! domain.  Based on the global domain dimension information that is
    346. 

  346. ! passed in it computes the patch and memory dimensions on this
    347. 

  347. ! distributed-memory process for parallel compilation when DM_PARALLEL is
    348. 

  348. ! defined in configure.wrf.  In this case, it relies on an external
    349. 

  349. ! communications package-contributed routine, wrf_dm_patch_domain. For
    350. 

  350. ! non-parallel compiles, it returns the patch and memory dimensions based
    351. 

  351. ! on the entire domain. In either case, the memory dimensions will be
    352. 

  352. ! larger than the patch dimensions, since they allow for distributed
    353. 

  353. ! memory halo regions (DM_PARALLEL only) and for boundary regions around
    354. 

  354. ! the domain (used for idealized cases only).  The width of the boundary
    355. 

  355. ! regions to be accommodated is passed in as bdx and bdy.
    356. 

  356. ! 
    357. 

  357. ! The bdy_mask argument is a four-dimensional logical array, each element
    358. 

  358. ! of which is set to true for any boundaries that this process's patch
    359. 

  359. ! contains (all four are true in the non-DM_PARALLEL case) and false
    360. 

  360. ! otherwise. The indices into the bdy_mask are defined in
    361. 

  361. ! frame/module_state_description.F. P_XSB corresponds boundary that
    362. 

  362. ! exists at the beginning of the X-dimension; ie. the western boundary;
    363. 

  363. ! P_XEB to the boundary that corresponds to the end of the X-dimension
    364. 

  364. ! (east). Likewise for Y (south and north respectively).
    365. 

  365. ! 
    366. 

  366. ! The correspondence of the first, second, and third dimension of each
    367. 

  367. ! set (domain, memory, and patch) with the coordinate axes of the model
    368. 

  368. ! domain is based on the setting of the variable model_data_order, which
    369. 

  369. ! comes into this routine through USE association of
    370. 

  370. ! module_driver_constants in the enclosing module of this routine,
    371. 

  371. ! module_domain.  Model_data_order is defined by the Registry, based on
    372. 

  372. ! the dimspec entries which associate dimension specifiers (e.g. 'k') in
    373. 

  373. ! the Registry with a coordinate axis and specify which dimension of the
    374. 

  374. ! arrays they represent. For WRF, the sd1 , ed1 , sp1 , ep1 , sm1 , and
    375. 

  375. ! em1 correspond to the starts and ends of the global, patch, and memory
    376. 

  376. ! dimensions in X; those with 2 specify Z (vertical); and those with 3
    377. 

  377. ! specify Y.  Note that the WRF convention is to overdimension to allow
    378. 

  378. ! for staggered fields so that sd<em>n</em>:ed<em>n</em> are the starts
    379. 

  379. ! and ends of the staggered domains in X.  The non-staggered grid runs
    380. 

  380. ! sd<em>n</em>:ed<em>n</em>-1. The extra row or column on the north or
    381. 

  381. ! east boundaries is not used for non-staggered fields.
    382. 

  382. ! 
    383. 

  383. ! The domdesc and parent_domdesc arguments are for external communication
    384. 

  384. ! packages (e.g. RSL) that establish and return to WRF integer handles
    385. 

  385. ! for referring to operations on domains.  These descriptors are not set
    386. 

  386. ! or used otherwise and they are opaque, which means they are never
    387. 

  387. ! accessed or modified in WRF; they are only only passed between calls to
    388. 

  388. ! the external package.
    389. 

  389. !</DESCRIPTION>
    390. 

  390. 

  391.    USE module_machine
    392. 

  392.    IMPLICIT NONE
    393. 

  393.    LOGICAL, DIMENSION(4), INTENT(OUT)  :: bdy_mask
    394. 

  394.    INTEGER, INTENT(IN)   :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
    395. 

  395.    INTEGER, INTENT(OUT)  :: sp1  , ep1  , sp2  , ep2  , sp3  , ep3  , &  ! z-xpose (std)
    396. 

  396.                             sm1  , em1  , sm2  , em2  , sm3  , em3
    397. 

  397.    INTEGER, INTENT(OUT)  :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , &  ! x-xpose
    398. 

  398.                             sm1x , em1x , sm2x , em2x , sm3x , em3x
    399. 

  399.    INTEGER, INTENT(OUT)  :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , &  ! y-xpose
    400. 

  400.                             sm1y , em1y , sm2y , em2y , sm3y , em3y
    401. 

  401.    INTEGER, INTENT(IN)   :: id , parent_id , parent_domdesc
    402. 

  402.    INTEGER, INTENT(INOUT)  :: domdesc
    403. 

  403.    TYPE(domain), POINTER :: parent
    404. 

  404. 

  405. !local data
    406. 

  406. 

  407.    INTEGER spec_bdy_width
    408. 

  408. 

  409.    CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
    410. 

  410. 

  411. #ifndef DM_PARALLEL
    412. 

  412. 

  413.    bdy_mask = .true.     ! only one processor so all 4 boundaries are there
    414. 

  414. 

  415. ! this is a trivial version -- 1 patch per processor; 
    416. 

  416. ! use version in module_dm to compute for DM
    417. 

  417.    sp1 = sd1 ; sp2 = sd2 ; sp3 = sd3
    418. 

  418.    ep1 = ed1 ; ep2 = ed2 ; ep3 = ed3
    419. 

  419.    SELECT CASE ( model_data_order )
    420. 

  420.       CASE ( DATA_ORDER_XYZ )
    421. 

  421.          sm1  = sp1 - bdx ; em1 = ep1 + bdx
    422. 

  422.          sm2  = sp2 - bdy ; em2 = ep2 + bdy
    423. 

  423.          sm3  = sp3       ; em3 = ep3
    424. 

  424.       CASE ( DATA_ORDER_YXZ )
    425. 

  425.          sm1 = sp1 - bdy ; em1 = ep1 + bdy
    426. 

  426.          sm2 = sp2 - bdx ; em2 = ep2 + bdx
    427. 

  427.          sm3 = sp3       ; em3 = ep3
    428. 

  428.       CASE ( DATA_ORDER_ZXY )
    429. 

  429.          sm1 = sp1       ; em1 = ep1
    430. 

  430.          sm2 = sp2 - bdx ; em2 = ep2 + bdx
    431. 

  431.          sm3 = sp3 - bdy ; em3 = ep3 + bdy
    432. 

  432.       CASE ( DATA_ORDER_ZYX )
    433. 

  433.          sm1 = sp1       ; em1 = ep1
    434. 

  434.          sm2 = sp2 - bdy ; em2 = ep2 + bdy
    435. 

  435.          sm3 = sp3 - bdx ; em3 = ep3 + bdx
    436. 

  436.       CASE ( DATA_ORDER_XZY )
    437. 

  437.          sm1 = sp1 - bdx ; em1 = ep1 + bdx
    438. 

  438.          sm2 = sp2       ; em2 = ep2
    439. 

  439.          sm3 = sp3 - bdy ; em3 = ep3 + bdy
    440. 

  440.       CASE ( DATA_ORDER_YZX )
    441. 

  441.          sm1 = sp1 - bdy ; em1 = ep1 + bdy
    442. 

  442.          sm2 = sp2       ; em2 = ep2
    443. 

  443.          sm3 = sp3 - bdx ; em3 = ep3 + bdx
    444. 

  444.    END SELECT
    445. 

  445.    sm1x = sm1       ; em1x = em1    ! just copy
    446. 

  446.    sm2x = sm2       ; em2x = em2
    447. 

  447.    sm3x = sm3       ; em3x = em3
    448. 

  448.    sm1y = sm1       ; em1y = em1    ! just copy
    449. 

  449.    sm2y = sm2       ; em2y = em2
    450. 

  450.    sm3y = sm3       ; em3y = em3
    451. 

  451. ! assigns mostly just to suppress warning messages that INTENT OUT vars not assigned
    452. 

  452.    sp1x = sp1 ; ep1x = ep1 ; sp2x = sp2 ; ep2x = ep2 ; sp3x = sp3 ; ep3x = ep3
    453. 

  453.    sp1y = sp1 ; ep1y = ep1 ; sp2y = sp2 ; ep2y = ep2 ; sp3y = sp3 ; ep3y = ep3
    454. 

  454. 

  455. #else
    456. 

  456. ! This is supplied by the package specific version of module_dm, which
    457. 

  457. ! is supplied by the external package and copied into the src directory
    458. 

  458. ! when the code is compiled. The cp command will be found in the externals
    459. 

  459. ! target of the configure.wrf file for this architecture.  Eg: for RSL
    460. 

  460. ! routine is defined in external/RSL/module_dm.F .
    461. 

  461. ! Note, it would be very nice to be able to pass parent to this routine;
    462. 

  462. ! however, there doesn't seem to be a way to do that in F90. That is because
    463. 

  463. ! to pass a pointer to a domain structure, this call requires an interface
    464. 

  464. ! definition for wrf_dm_patch_domain (otherwise it will try to convert the
    465. 

  465. ! pointer to something). In order to provide an interface definition, we
    466. 

  466. ! would need to either USE module_dm or use an interface block. In either
    467. 

  467. ! case it generates a circular USE reference, since module_dm uses
    468. 

  468. ! module_domain.  JM 20020416
    469. 

  469. 

  470.    CALL wrf_dm_patch_domain( id , domdesc , parent_id , parent_domdesc , &
    471. 

  471.                              sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
    472. 

  472.                              sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
    473. 

  473.                              sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
    474. 

  474.                                          sp1x , ep1x , sm1x , em1x , &
    475. 

  475.                                          sp2x , ep2x , sm2x , em2x , &
    476. 

  476.                                          sp3x , ep3x , sm3x , em3x , &
    477. 

  477.                                          sp1y , ep1y , sm1y , em1y , &
    478. 

  478.                                          sp2y , ep2y , sm2y , em2y , &
    479. 

  479.                                          sp3y , ep3y , sm3y , em3y , &
    480. 

  480.                              bdx , bdy )
    481. 

  481. 

  482.    SELECT CASE ( model_data_order )
    483. 

  483.       CASE ( DATA_ORDER_XYZ )
    484. 

  484.    bdy_mask( P_XSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
    485. 

  485.    bdy_mask( P_YSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
    486. 

  486.    bdy_mask( P_XEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
    487. 

  487.    bdy_mask( P_YEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
    488. 

  488.       CASE ( DATA_ORDER_YXZ )
    489. 

  489.    bdy_mask( P_XSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
    490. 

  490.    bdy_mask( P_YSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
    491. 

  491.    bdy_mask( P_XEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
    492. 

  492.    bdy_mask( P_YEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
    493. 

  493.       CASE ( DATA_ORDER_ZXY )
    494. 

  494.    bdy_mask( P_XSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
    495. 

  495.    bdy_mask( P_YSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
    496. 

  496.    bdy_mask( P_XEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
    497. 

  497.    bdy_mask( P_YEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
    498. 

  498.       CASE ( DATA_ORDER_ZYX )
    499. 

  499.    bdy_mask( P_XSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
    500. 

  500.    bdy_mask( P_YSB ) = ( sd2                  <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 )
    501. 

  501.    bdy_mask( P_XEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
    502. 

  502.    bdy_mask( P_YEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2                  )
    503. 

  503.       CASE ( DATA_ORDER_XZY )
    504. 

  504.    bdy_mask( P_XSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
    505. 

  505.    bdy_mask( P_YSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
    506. 

  506.    bdy_mask( P_XEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
    507. 

  507.    bdy_mask( P_YEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
    508. 

  508.       CASE ( DATA_ORDER_YZX )
    509. 

  509.    bdy_mask( P_XSB ) = ( sd3                  <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 )
    510. 

  510.    bdy_mask( P_YSB ) = ( sd1                  <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 )
    511. 

  511.    bdy_mask( P_XEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3                  )
    512. 

  512.    bdy_mask( P_YEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1                  )
    513. 

  513.    END SELECT
    514. 

  514. 

  515. #endif
    516. 

  516. 

  517.    RETURN
    518. 

  518.    END SUBROUTINE wrf_patch_domain
    519. 

  519. !
    520. 

  520.    SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid )
    521. 

  521. 

  522. !<DESCRIPTION>
    523. 

  523. ! This subroutine is used to allocate a domain data structure of
    524. 

  524. ! TYPE(DOMAIN) pointed to by the argument <em>grid</em>, link it into the
    525. 

  525. ! nested domain hierarchy, and set it's configuration information from
    526. 

  526. ! the appropriate settings in the WRF namelist file. Specifically, if the
    527. 

  527. ! domain being allocated and configured is nest, the <em>parent</em>
    528. 

  528. ! argument will point to the already existing domain data structure for
    529. 

  529. ! the parent domain and the <em>kid</em> argument will be set to an
    530. 

  530. ! integer indicating which child of the parent this grid will be (child
    531. 

  531. ! indices start at 1).  If this is the top-level domain, the parent and
    532. 

  532. ! kid arguments are ignored.  <b>WRF domains may have multiple children
    533. 

  533. ! but only ever have one parent.</b>
    534. 

  534. !
    535. 

  535. ! The <em>domain_id</em> argument is the
    536. 

  536. ! integer handle by which this new domain will be referred; it comes from
    537. 

  537. ! the grid_id setting in the namelist, and these grid ids correspond to
    538. 

  538. ! the ordering of settings in the namelist, starting with 1 for the
    539. 

  539. ! top-level domain. The id of 1 always corresponds to the top-level
    540. 

  540. ! domain.  and these grid ids correspond to the ordering of settings in
    541. 

  541. ! the namelist, starting with 1 for the top-level domain.
    542. 

  542. ! 
    543. 

  543. ! Model_data_order is provide by USE association of
    544. 

  544. ! module_driver_constants and is set from dimspec entries in the
    545. 

  545. ! Registry.
    546. 

  546. ! 
    547. 

  547. ! The allocation of the TYPE(DOMAIN) itself occurs in this routine.
    548. 

  548. ! However, the numerous multi-dimensional arrays that make up the members
    549. 

  549. ! of the domain are allocated in the call to alloc_space_field, after
    550. 

  550. ! wrf_patch_domain has been called to determine the dimensions in memory
    551. 

  551. ! that should be allocated.  It bears noting here that arrays and code
    552. 

  552. ! that indexes these arrays are always global, regardless of how the
    553. 

  553. ! model is decomposed over patches. Thus, when arrays are allocated on a
    554. 

  554. ! given process, the start and end of an array dimension are the global
    555. 

  555. ! indices of the start and end of that process's subdomain.
    556. 

  556. ! 
    557. 

  557. ! Configuration information for the domain (that is, information from the
    558. 

  558. ! namelist) is added by the call to <a href=med_add_config_info_to_grid.html>med_add_config_info_to_grid</a>, defined
    559. 

  559. ! in share/mediation_wrfmain.F. 
    560. 

  560. !</DESCRIPTION>
    561. 

  561. 

  562.       IMPLICIT NONE
    563. 

  563. 

  564.       !  Input data.
    565. 

  565. 

  566.       INTEGER , INTENT(IN)                           :: domain_id
    567. 

  567.       TYPE( domain ) , POINTER                       :: grid
    568. 

  568.       TYPE( domain ) , POINTER                       :: parent
    569. 

  569.       INTEGER , INTENT(IN)                           :: kid    ! which kid of parent am I?
    570. 

  570. 

  571.       !  Local data.
    572. 

  572.       INTEGER                     :: sd1 , ed1 , sp1 , ep1 , sm1 , em1
    573. 

  573.       INTEGER                     :: sd2 , ed2 , sp2 , ep2 , sm2 , em2
    574. 

  574.       INTEGER                     :: sd3 , ed3 , sp3 , ep3 , sm3 , em3
    575. 

  575. 

  576.       INTEGER                     :: sd1x , ed1x , sp1x , ep1x , sm1x , em1x
    577. 

  577.       INTEGER                     :: sd2x , ed2x , sp2x , ep2x , sm2x , em2x
    578. 

  578.       INTEGER                     :: sd3x , ed3x , sp3x , ep3x , sm3x , em3x
    579. 

  579. 

  580.       INTEGER                     :: sd1y , ed1y , sp1y , ep1y , sm1y , em1y
    581. 

  581.       INTEGER                     :: sd2y , ed2y , sp2y , ep2y , sm2y , em2y
    582. 

  582.       INTEGER                     :: sd3y , ed3y , sp3y , ep3y , sm3y , em3y
    583. 

  583. 

  584.       TYPE(domain) , POINTER      :: new_grid
    585. 

  585.       INTEGER                     :: i
    586. 

  586.       INTEGER                     :: parent_id , parent_domdesc , new_domdesc
    587. 

  587.       INTEGER                     :: bdyzone_x , bdyzone_y
    588. 

  588.       INTEGER                     :: nx, ny
    589. 

  589. 

  590. 

  591. ! This next step uses information that is listed in the registry as namelist_derived
    592. 

  592. ! to properly size the domain and the patches; this in turn is stored in the new_grid
    593. 

  593. ! data structure
    594. 

  594. 

  595. 

  596.       data_ordering : SELECT CASE ( model_data_order )
    597. 

  597.         CASE  ( DATA_ORDER_XYZ )
    598. 

  598. 

  599.           CALL nl_get_s_we( domain_id , sd1 )
    600. 

  600.           CALL nl_get_e_we( domain_id , ed1 )
    601. 

  601.           CALL nl_get_s_sn( domain_id , sd2 )
    602. 

  602.           CALL nl_get_e_sn( domain_id , ed2 )
    603. 

  603.           CALL nl_get_s_vert( domain_id , sd3 )
    604. 

  604.           CALL nl_get_e_vert( domain_id , ed3 )
    605. 

  605.           nx = ed1-sd1+1
    606. 

  606.           ny = ed2-sd2+1
    607. 

  607. 

  608.         CASE  ( DATA_ORDER_YXZ )
    609. 

  609. 

  610.           CALL nl_get_s_sn( domain_id , sd1 )
    611. 

  611.           CALL nl_get_e_sn( domain_id , ed1 )
    612. 

  612.           CALL nl_get_s_we( domain_id , sd2 )
    613. 

  613.           CALL nl_get_e_we( domain_id , ed2 )
    614. 

  614.           CALL nl_get_s_vert( domain_id , sd3 )
    615. 

  615.           CALL nl_get_e_vert( domain_id , ed3 )
    616. 

  616.           nx = ed2-sd2+1
    617. 

  617.           ny = ed1-sd1+1
    618. 

  618. 

  619.         CASE  ( DATA_ORDER_ZXY )
    620. 

  620. 

  621.           CALL nl_get_s_vert( domain_id , sd1 )
    622. 

  622.           CALL nl_get_e_vert( domain_id , ed1 )
    623. 

  623.           CALL nl_get_s_we( domain_id , sd2 )
    624. 

  624.           CALL nl_get_e_we( domain_id , ed2 )
    625. 

  625.           CALL nl_get_s_sn( domain_id , sd3 )
    626. 

  626.           CALL nl_get_e_sn( domain_id , ed3 )
    627. 

  627.           nx = ed2-sd2+1
    628. 

  628.           ny = ed3-sd3+1
    629. 

  629. 

  630.         CASE  ( DATA_ORDER_ZYX )
    631. 

  631. 

  632.           CALL nl_get_s_vert( domain_id , sd1 )
    633. 

  633.           CALL nl_get_e_vert( domain_id , ed1 )
    634. 

  634.           CALL nl_get_s_sn( domain_id , sd2 )
    635. 

  635.           CALL nl_get_e_sn( domain_id , ed2 )
    636. 

  636.           CALL nl_get_s_we( domain_id , sd3 )
    637. 

  637.           CALL nl_get_e_we( domain_id , ed3 )
    638. 

  638.           nx = ed3-sd3+1
    639. 

  639.           ny = ed2-sd2+1
    640. 

  640. 

  641.         CASE  ( DATA_ORDER_XZY )
    642. 

  642. 

  643.           CALL nl_get_s_we( domain_id , sd1 )
    644. 

  644.           CALL nl_get_e_we( domain_id , ed1 )
    645. 

  645.           CALL nl_get_s_vert( domain_id , sd2 )
    646. 

  646.           CALL nl_get_e_vert( domain_id , ed2 )
    647. 

  647.           CALL nl_get_s_sn( domain_id , sd3 )
    648. 

  648.           CALL nl_get_e_sn( domain_id , ed3 )
    649. 

  649.           nx = ed1-sd1+1
    650. 

  650.           ny = ed3-sd3+1
    651. 

  651. 

  652.         CASE  ( DATA_ORDER_YZX )
    653. 

  653. 

  654.           CALL nl_get_s_sn( domain_id , sd1 )
    655. 

  655.           CALL nl_get_e_sn( domain_id , ed1 )
    656. 

  656.           CALL nl_get_s_vert( domain_id , sd2 )
    657. 

  657.           CALL nl_get_e_vert( domain_id , ed2 )
    658. 

  658.           CALL nl_get_s_we( domain_id , sd3 )
    659. 

  659.           CALL nl_get_e_we( domain_id , ed3 )
    660. 

  660.           nx = ed3-sd3+1
    661. 

  661.           ny = ed1-sd1+1
    662. 

  662. 

  663.       END SELECT data_ordering
    664. 

  664. 

  665.       IF ( num_time_levels > 3 ) THEN
    666. 

  666.         WRITE ( wrf_err_message , * ) 'alloc_and_configure_domain: ', &
    667. 

  667.           'Incorrect value for num_time_levels ', num_time_levels
    668. 

  668.         CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
    669. 

  669.       ENDIF
    670. 

  670. 

  671.       IF (ASSOCIATED(parent)) THEN
    672. 

  672.         parent_id = parent%id
    673. 

  673.         parent_domdesc = parent%domdesc
    674. 

  674.       ELSE
    675. 

  675.         parent_id = -1
    676. 

  676.         parent_domdesc = -1
    677. 

  677.       ENDIF
    678. 

  678. 

  679. ! provided by application, WRF defines in share/module_bc.F
    680. 

  680.       CALL get_bdyzone_x( bdyzone_x )
    681. 

  681.       CALL get_bdyzone_y( bdyzone_y )
    682. 

  682. 

  683.       ALLOCATE ( new_grid )
    684. 

  684.       ALLOCATE( new_grid%head_statevars )
    685. 

  685.       NULLIFY( new_grid%head_statevars%next)
    686. 

  686.       new_grid%tail_statevars => new_grid%head_statevars 
    687. 

  687. 

  688.       ALLOCATE ( new_grid%parents( max_parents ) ) 
    689. 

  689.       ALLOCATE ( new_grid%nests( max_nests ) )
    690. 

  690.       NULLIFY( new_grid%sibling )
    691. 

  691.       DO i = 1, max_nests
    692. 

  692.          NULLIFY( new_grid%nests(i)%ptr )
    693. 

  693.       ENDDO
    694. 

  694.       NULLIFY  (new_grid%next)
    695. 

  695.       NULLIFY  (new_grid%same_level)
    696. 

  696.       NULLIFY  (new_grid%i_start)
    697. 

  697.       NULLIFY  (new_grid%j_start)
    698. 

  698.       NULLIFY  (new_grid%i_end)
    699. 

  699.       NULLIFY  (new_grid%j_end)
    700. 

  700.       ALLOCATE( new_grid%domain_clock )
    701. 

  701.       new_grid%domain_clock_created = .FALSE.
    702. 

  702.       ALLOCATE( new_grid%alarms( MAX_WRF_ALARMS ) )    ! initialize in setup_timekeeping
    703. 

  703.       ALLOCATE( new_grid%alarms_created( MAX_WRF_ALARMS ) )
    704. 

  704.       DO i = 1, MAX_WRF_ALARMS
    705. 

  705.         new_grid%alarms_created( i ) = .FALSE.
    706. 

  706.       ENDDO
    707. 

  707.       new_grid%time_set = .FALSE.
    708. 

  708.       new_grid%is_intermediate = .FALSE.
    709. 

  709.       new_grid%have_displayed_alloc_stats = .FALSE.
    710. 

  710. 

  711.       ! set up the pointers that represent the nest hierarchy
    712. 

  712.       ! set this up *prior* to calling the patching or allocation
    713. 

  713.       ! routines so that implementations of these routines can
    714. 

  714.       ! traverse the nest hierarchy (through the root head_grid)
    715. 

  715.       ! if they need to 
    716. 

  716. 

  717.  
    718. 

  718.       IF ( domain_id .NE. 1 ) THEN
    719. 

  719.          new_grid%parents(1)%ptr => parent
    720. 

  720.          new_grid%num_parents = 1
    721. 

  721.          parent%nests(kid)%ptr => new_grid
    722. 

  722.          new_grid%child_of_parent(1) = kid    ! note assumption that nest can have only 1 parent
    723. 

  723.          parent%num_nests = parent%num_nests + 1
    724. 

  724.       END IF
    725. 

  725.       new_grid%id = domain_id                 ! this needs to be assigned prior to calling wrf_patch_domain
    726. 

  726. 

  727.       CALL wrf_patch_domain( domain_id  , new_domdesc , parent, parent_id, parent_domdesc , &
    728. 

  728. 

  729.                              sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &     ! z-xpose dims
    730. 

  730.                              sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &     ! (standard)
    731. 

  731.                              sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
    732. 

  732. 

  733.                                      sp1x , ep1x , sm1x , em1x , &     ! x-xpose dims
    734. 

  734.                                      sp2x , ep2x , sm2x , em2x , &
    735. 

  735.                                      sp3x , ep3x , sm3x , em3x , &
    736. 

  736. 

  737.                                      sp1y , ep1y , sm1y , em1y , &     ! y-xpose dims
    738. 

  738.                                      sp2y , ep2y , sm2y , em2y , &
    739. 

  739.                                      sp3y , ep3y , sm3y , em3y , &
    740. 

  740. 

  741.                          bdyzone_x  , bdyzone_y , new_grid%bdy_mask &
    742. 

  742.       ) 
    743. 

  743. 

  744. 

  745.       new_grid%domdesc = new_domdesc
    746. 

  746.       new_grid%num_nests = 0
    747. 

  747.       new_grid%num_siblings = 0
    748. 

  748.       new_grid%num_parents = 0
    749. 

  749.       new_grid%max_tiles   = 0
    750. 

  750.       new_grid%num_tiles_spec   = 0
    751. 

  751.       new_grid%nframes   = 0         ! initialize the number of frames per file (array assignment)
    752. 

  752. #if (EM_CORE == 1)
    753. 

  753.       new_grid%stepping_to_time = .FALSE.
    754. 

  754.       new_grid%adaptation_domain = 1
    755. 

  755.       new_grid%last_step_updated = -1
    756. 

  756. #endif
    757. 

  757. 

  758.       CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. ,      &
    759. 

  759.                                sd1, ed1, sd2, ed2, sd3, ed3,       &
    760. 

  760.                                sm1,  em1,  sm2,  em2,  sm3,  em3,  &
    761. 

  761.                                sp1,  ep1,  sp2,  ep2,  sp3,  ep3,  &
    762. 

  762.                                sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
    763. 

  763.                                sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
    764. 

  764.                                sm1x, em1x, sm2x, em2x, sm3x, em3x, &   ! x-xpose
    765. 

  765.                                sm1y, em1y, sm2y, em2y, sm3y, em3y  &   ! y-xpose
    766. 

  766.       )
    767. 

  767. #if MOVE_NESTS
    768. 

  768. !set these here, after alloc_space_field, which initializes vc_i, vc_j to zero
    769. 

  769.       new_grid%xi = -1.0
    770. 

  770.       new_grid%xj = -1.0
    771. 

  771.       new_grid%vc_i = -1.0
    772. 

  772.       new_grid%vc_j = -1.0
    773. 

  773. #endif
    774. 

  774. 

  775.       new_grid%sd31                            = sd1 
    776. 

  776.       new_grid%ed31                            = ed1
    777. 

  777.       new_grid%sp31                            = sp1 
    778. 

  778.       new_grid%ep31                            = ep1 
    779. 

  779.       new_grid%sm31                            = sm1 
    780. 

  780.       new_grid%em31                            = em1
    781. 

  781.       new_grid%sd32                            = sd2 
    782. 

  782.       new_grid%ed32                            = ed2
    783. 

  783.       new_grid%sp32                            = sp2 
    784. 

  784.       new_grid%ep32                            = ep2 
    785. 

  785.       new_grid%sm32                            = sm2 
    786. 

  786.       new_grid%em32                            = em2
    787. 

  787.       new_grid%sd33                            = sd3 
    788. 

  788.       new_grid%ed33                            = ed3
    789. 

  789.       new_grid%sp33                            = sp3 
    790. 

  790.       new_grid%ep33                            = ep3 
    791. 

  791.       new_grid%sm33                            = sm3 
    792. 

  792.       new_grid%em33                            = em3
    793. 

  793. 

  794.       new_grid%sp31x                           = sp1x
    795. 

  795.       new_grid%ep31x                           = ep1x
    796. 

  796.       new_grid%sm31x                           = sm1x
    797. 

  797.       new_grid%em31x                           = em1x
    798. 

  798.       new_grid%sp32x                           = sp2x
    799. 

  799.       new_grid%ep32x                           = ep2x
    800. 

  800.       new_grid%sm32x                           = sm2x
    801. 

  801.       new_grid%em32x                           = em2x
    802. 

  802.       new_grid%sp33x                           = sp3x
    803. 

  803.       new_grid%ep33x                           = ep3x
    804. 

  804.       new_grid%sm33x                           = sm3x
    805. 

  805.       new_grid%em33x                           = em3x
    806. 

  806. 

  807.       new_grid%sp31y                           = sp1y
    808. 

  808.       new_grid%ep31y                           = ep1y
    809. 

  809.       new_grid%sm31y                           = sm1y
    810. 

  810.       new_grid%em31y                           = em1y
    811. 

  811.       new_grid%sp32y                           = sp2y
    812. 

  812.       new_grid%ep32y                           = ep2y
    813. 

  813.       new_grid%sm32y                           = sm2y
    814. 

  814.       new_grid%em32y                           = em2y
    815. 

  815.       new_grid%sp33y                           = sp3y
    816. 

  816.       new_grid%ep33y                           = ep3y
    817. 

  817.       new_grid%sm33y                           = sm3y
    818. 

  818.       new_grid%em33y                           = em3y
    819. 

  819. 

  820.       SELECT CASE ( model_data_order )
    821. 

  821.          CASE  ( DATA_ORDER_XYZ )
    822. 

  822.             new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
    823. 

  823.             new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
    824. 

  824.             new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
    825. 

  825.             new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
    826. 

  826.             new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
    827. 

  827.             new_grid%em21 = em1 ; new_grid%em22 = em2 ;
    828. 

  828.             new_grid%sd11 = sd1
    829. 

  829.             new_grid%ed11 = ed1
    830. 

  830.             new_grid%sp11 = sp1
    831. 

  831.             new_grid%ep11 = ep1
    832. 

  832.             new_grid%sm11 = sm1
    833. 

  833.             new_grid%em11 = em1
    834. 

  834.          CASE  ( DATA_ORDER_YXZ )
    835. 

  835.             new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
    836. 

  836.             new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
    837. 

  837.             new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
    838. 

  838.             new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
    839. 

  839.             new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
    840. 

  840.             new_grid%em21 = em1 ; new_grid%em22 = em2 ;
    841. 

  841.             new_grid%sd11 = sd1
    842. 

  842.             new_grid%ed11 = ed1
    843. 

  843.             new_grid%sp11 = sp1
    844. 

  844.             new_grid%ep11 = ep1
    845. 

  845.             new_grid%sm11 = sm1
    846. 

  846.             new_grid%em11 = em1
    847. 

  847.          CASE  ( DATA_ORDER_ZXY )
    848. 

  848.             new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
    849. 

  849.             new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
    850. 

  850.             new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
    851. 

  851.             new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
    852. 

  852.             new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
    853. 

  853.             new_grid%em21 = em2 ; new_grid%em22 = em3 ;
    854. 

  854.             new_grid%sd11 = sd2
    855. 

  855.             new_grid%ed11 = ed2
    856. 

  856.             new_grid%sp11 = sp2
    857. 

  857.             new_grid%ep11 = ep2
    858. 

  858.             new_grid%sm11 = sm2
    859. 

  859.             new_grid%em11 = em2
    860. 

  860.          CASE  ( DATA_ORDER_ZYX )
    861. 

  861.             new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
    862. 

  862.             new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
    863. 

  863.             new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
    864. 

  864.             new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
    865. 

  865.             new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
    866. 

  866.             new_grid%em21 = em2 ; new_grid%em22 = em3 ;
    867. 

  867.             new_grid%sd11 = sd2
    868. 

  868.             new_grid%ed11 = ed2
    869. 

  869.             new_grid%sp11 = sp2
    870. 

  870.             new_grid%ep11 = ep2
    871. 

  871.             new_grid%sm11 = sm2
    872. 

  872.             new_grid%em11 = em2
    873. 

  873.          CASE  ( DATA_ORDER_XZY )
    874. 

  874.             new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
    875. 

  875.             new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
    876. 

  876.             new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
    877. 

  877.             new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
    878. 

  878.             new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
    879. 

  879.             new_grid%em21 = em1 ; new_grid%em22 = em3 ;
    880. 

  880.             new_grid%sd11 = sd1
    881. 

  881.             new_grid%ed11 = ed1
    882. 

  882.             new_grid%sp11 = sp1
    883. 

  883.             new_grid%ep11 = ep1
    884. 

  884.             new_grid%sm11 = sm1
    885. 

  885.             new_grid%em11 = em1
    886. 

  886.          CASE  ( DATA_ORDER_YZX )
    887. 

  887.             new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
    888. 

  888.             new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
    889. 

  889.             new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
    890. 

  890.             new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
    891. 

  891.             new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
    892. 

  892.             new_grid%em21 = em1 ; new_grid%em22 = em3 ;
    893. 

  893.             new_grid%sd11 = sd1
    894. 

  894.             new_grid%ed11 = ed1
    895. 

  895.             new_grid%sp11 = sp1
    896. 

  896.             new_grid%ep11 = ep1
    897. 

  897.             new_grid%sm11 = sm1
    898. 

  898.             new_grid%em11 = em1
    899. 

  899.       END SELECT
    900. 

  900. 

  901.       CALL med_add_config_info_to_grid ( new_grid )           ! this is a mediation layer routine
    902. 

  902. 

  903. ! Some miscellaneous state that is in the Registry but not namelist data
    904. 

  904. 

  905.       new_grid%tiled                           = .false.
    906. 

  906.       new_grid%patched                         = .false.
    907. 

  907.       NULLIFY(new_grid%mapping)
    908. 

  908. 

  909. ! This next set of includes causes all but the namelist_derived variables to be
    910. 

  910. ! properly assigned to the new_grid record
    911. 

  911. 

  912.       grid => new_grid
    913. 

  913. 

  914. ! Allocate storage for time series metadata
    915. 

  915.       ALLOCATE( grid%lattsloc( grid%max_ts_locs ) )
    916. 

  916.       ALLOCATE( grid%lontsloc( grid%max_ts_locs ) )
    917. 

  917.       ALLOCATE( grid%nametsloc( grid%max_ts_locs ) )
    918. 

  918.       ALLOCATE( grid%desctsloc( grid%max_ts_locs ) )
    919. 

  919.       ALLOCATE( grid%itsloc( grid%max_ts_locs ) )
    920. 

  920.       ALLOCATE( grid%jtsloc( grid%max_ts_locs ) )
    921. 

  921.       ALLOCATE( grid%id_tsloc( grid%max_ts_locs ) )
    922. 

  922.       ALLOCATE( grid%ts_filename( grid%max_ts_locs ) )
    923. 

  923.       grid%ntsloc        = 0
    924. 

  924.       grid%ntsloc_domain = 0
    925. 

  925. 

  926. #if (EM_CORE == 1)
    927. 

  927. ! Allocate storage for track metadata
    928. 

  928.       ALLOCATE( grid%track_time_in( grid%track_loc_in ) )
    929. 

  929.       ALLOCATE( grid%track_lat_in( grid%track_loc_in ) )
    930. 

  930.       ALLOCATE( grid%track_lon_in( grid%track_loc_in ) )
    931. 

  931. 

  932.       ALLOCATE( grid%track_time_domain( grid%track_loc_in ) )
    933. 

  933.       ALLOCATE( grid%track_lat_domain( grid%track_loc_in ) )
    934. 

  934.       ALLOCATE( grid%track_lon_domain( grid%track_loc_in ) )
    935. 

  935.       ALLOCATE( grid%track_i( grid%track_loc_in ) )
    936. 

  936.       ALLOCATE( grid%track_j( grid%track_loc_in ) )
    937. 

  937. 

  938.       grid%track_loc        = 0
    939. 

  939.       grid%track_loc_domain = 0
    940. 

  940.       grid%track_have_calculated = .FALSE.
    941. 

  941.       grid%track_have_input      = .FALSE.
    942. 

  942. #endif
    943. 

  943. #ifdef DM_PARALLEL
    944. 

  944.       CALL wrf_get_dm_communicator ( grid%communicator )
    945. 

  945.       CALL wrf_dm_define_comms( grid )
    946. 

  946. #endif
    947. 

  947. 

  948.    END SUBROUTINE alloc_and_configure_domain
    949. 

  949. 

  950.    SUBROUTINE get_fieldstr(ix,c,instr,outstr,noutstr,noerr)
    951. 

  951.      IMPLICIT NONE
    952. 

  952.      INTEGER, INTENT(IN)          :: ix
    953. 

  953.      CHARACTER*(*), INTENT(IN)    :: c
    954. 

  954.      CHARACTER*(*), INTENT(IN)    :: instr
    955. 

  955.      CHARACTER*(*), INTENT(OUT)   :: outstr
    956. 

  956.      INTEGER,       INTENT(IN)    :: noutstr  ! length of outstr
    957. 

  957.      LOGICAL,       INTENT(INOUT) :: noerr     ! status
    958. 

  958.      !local
    959. 

  959.      INTEGER, PARAMETER :: MAX_DEXES = 100
    960. 

  960.      INTEGER I, PREV, IDEX
    961. 

  961.      INTEGER DEXES(MAX_DEXES)
    962. 

  962.      outstr = ""
    963. 

  963.      prev = 1
    964. 

  964.      dexes(1) = 1
    965. 

  965.      DO i = 2,MAX_DEXES
    966. 

  966.        idex = INDEX(instr(prev:LEN(TRIM(instr))),c)
    967. 

  967.        IF ( idex .GT. 0 ) THEN
    968. 

  968.          dexes(i) = idex+prev
    969. 

  969.          prev = dexes(i)+1
    970. 

  970.        ELSE
    971. 

  971.          dexes(i) = LEN(TRIM(instr))+2
    972. 

  972.        ENDIF
    973. 

  973.      ENDDO
    974. 

  974. 

  975.      IF     ( (dexes(ix+1)-2)-(dexes(ix)) .GT. noutstr ) THEN
    976. 

  976.        noerr = .FALSE.  ! would overwrite
    977. 

  977.      ELSE IF( dexes(ix) .EQ. dexes(ix+1) ) THEN 
    978. 

  978.        noerr = .FALSE.  ! not found
    979. 

  979.      ELSE
    980. 

  980.        outstr = instr(dexes(ix):(dexes(ix+1)-2))
    981. 

  981.        noerr = noerr .AND. .TRUE.
    982. 

  982.      ENDIF
    983. 

  983.    END SUBROUTINE get_fieldstr
    984. 

  984. 

  985.    SUBROUTINE change_to_lower_case(instr,outstr)
    986. 

  986.      CHARACTER*(*) ,INTENT(IN)  :: instr
    987. 

  987.      CHARACTER*(*) ,INTENT(OUT) :: outstr
    988. 

  988. !Local
    989. 

  989.      CHARACTER*1                :: c
    990. 

  990.      INTEGER       ,PARAMETER   :: upper_to_lower =IACHAR('a')-IACHAR('A')
    991. 

  991.      INTEGER                    :: i,n,n1
    992. 

  992. !
    993. 

  993.      outstr = ' '
    994. 

  994.      N = len(instr)
    995. 

  995.      N1 = len(outstr)
    996. 

  996.      N = MIN(N,N1)
    997. 

  997.      outstr(1:N) = instr(1:N)
    998. 

  998.      DO i=1,N
    999. 

  999.        c = instr(i:i)
    1000. 

  1000.        if('A'<=c .and. c <='Z') outstr(i:i)=achar(iachar(c)+upper_to_lower)
    1001. 

  1001.      ENDDO
    1002. 

  1002.      RETURN
    1003. 

  1003.    END SUBROUTINE change_to_lower_case
    1004. 

  1004. 

  1005. !
    1006. 

  1006.    SUBROUTINE modify_io_masks1 ( grid , id )
    1007. 

  1007.       IMPLICIT NONE
    1008. 

  1008. #include "streams.h"
    1009. 

  1009.       INTEGER              , INTENT(IN  )  :: id
    1010. 

  1010.       TYPE(domain), POINTER                :: grid
    1011. 

  1011.       ! Local
    1012. 

  1012.       TYPE(fieldlist), POINTER :: p, q
    1013. 

  1013.       INTEGER, PARAMETER :: read_unit = 10
    1014. 

  1014.       LOGICAL, EXTERNAL  :: wrf_dm_on_monitor
    1015. 

  1015.       CHARACTER*256      :: fname, inln, mess, dname, t1, lookee
    1016. 

  1016.       CHARACTER*256      :: fieldlst
    1017. 

  1017.       CHARACTER*1        :: op, strmtyp
    1018. 

  1018.       CHARACTER*3        :: strmid
    1019. 

  1019.       CHARACTER*10       :: strmtyp_name
    1020. 

  1020.       INTEGER            :: io_status
    1021. 

  1021.       INTEGER            :: strmtyp_int, count_em
    1022. 

  1022.       INTEGER            :: lineno, fieldno, istrm, retval, itrace
    1023. 

  1023.       LOGICAL            :: keepgoing, noerr, gavewarning, ignorewarning, found
    1024. 

  1024.       LOGICAL, SAVE      :: you_warned_me = .FALSE.
    1025. 

  1025.       LOGICAL, SAVE      :: you_warned_me2(max_hst_mods,max_domains) = .FALSE.
    1026. 

  1026. 

  1027.       gavewarning = .FALSE.
    1028. 

  1028. 

  1029.       CALL nl_get_iofields_filename( id, fname )
    1030. 

  1030. 

  1031.       IF ( grid%is_intermediate ) RETURN                ! short circuit
    1032. 

  1032.       IF ( TRIM(fname) .EQ. "NONE_SPECIFIED" ) RETURN   ! short circuit
    1033. 

  1033. 

  1034.       IF ( wrf_dm_on_monitor() ) THEN
    1035. 

  1035.         OPEN ( UNIT   = read_unit    ,      &
    1036. 

  1036.                FILE   = TRIM(fname)      ,      &
    1037. 

  1037.                FORM   = "FORMATTED"      ,      &
    1038. 

  1038.                STATUS = "OLD"            ,      &
    1039. 

  1039.                IOSTAT = io_status         )
    1040. 

  1040.         IF ( io_status .EQ. 0 ) THEN   ! only on success
    1041. 

  1041.           keepgoing = .TRUE.
    1042. 

  1042.           lineno = 0
    1043. 

  1043.           count_em = 0    ! Count the total number of fields
    1044. 

  1044.           DO WHILE ( keepgoing )
    1045. 

  1045.             READ(UNIT=read_unit,FMT='(A)',IOSTAT=io_status) inln
    1046. 

  1046.             keepgoing = (io_status .EQ. 0) .AND. (LEN(TRIM(inln)) .GT. 0)  
    1047. 

  1047.             IF ( keepgoing ) THEN
    1048. 

  1048.               lineno = lineno + 1
    1049. 

  1049.               IF ( .NOT. LEN(TRIM(inln)) .LT. LEN(inln) ) THEN
    1050. 

  1050.                 WRITE(mess,*)'W A R N I N G : Line ',lineno,' of ',TRIM(fname),' is too long. Limit is ',LEN(inln),' characters.' 
    1051. 

  1051.                 gavewarning = .TRUE.
    1052. 

  1052.               ENDIF
    1053. 

  1053.               IF ( INDEX(inln,'#') .EQ. 0 ) THEN   ! skip comments, which is a # anywhere on line
    1054. 

  1054.                 IF ( keepgoing ) THEN
    1055. 

  1055.                   noerr = .TRUE.
    1056. 

  1056.                   CALL get_fieldstr(1,':',inln,op,1,noerr)          ! + is add, - is remove
    1057. 

  1057.                   IF ( TRIM(op) .NE. '+' .AND. TRIM(op) .NE. '-' ) THEN
    1058. 

  1058.                     WRITE(mess,*)'W A R N I N G : unknown operation ',TRIM(op),' (should be + or -). Line ',lineno
    1059. 

  1059.                     gavewarning = .TRUE.
    1060. 

  1060.                   ENDIF
    1061. 

  1061.                   CALL get_fieldstr(2,':',inln,t1,1,noerr)          ! i is input, h is history
    1062. 

  1062.                   CALL change_to_lower_case(t1,strmtyp) 
    1063. 

  1063. 

  1064.                   SELECT CASE (TRIM(strmtyp))
    1065. 

  1065.                   CASE ('h')
    1066. 

  1066.                      strmtyp_name = 'history'
    1067. 

  1067.                      strmtyp_int  = first_history
    1068. 

  1068.                   CASE ('i')
    1069. 

  1069.                      strmtyp_name = 'input'
    1070. 

  1070.                      strmtyp_int  = first_input
    1071. 

  1071.                   CASE DEFAULT
    1072. 

  1072.                      WRITE(mess,*)'W A R N I N G : unknown stream type ',TRIM(strmtyp),'. Line ',lineno
    1073. 

  1073.                      gavewarning = .TRUE.
    1074. 

  1074.                   END SELECT
    1075. 

  1075. 

  1076.                   CALL get_fieldstr(3,':',inln,strmid,3,noerr)      ! number of stream (main input and hist are 0)
    1077. 

  1077.                   READ(strmid,'(I3)') istrm
    1078. 

  1078.                   IF ( istrm .LT. 0 .OR. istrm .GT. last_history ) THEN
    1079. 

  1079.                     WRITE(mess,*)'W A R N I N G : invalid stream id ',istrm,' (should be 0 <= id <= ',last_history,'). Line ',lineno
    1080. 

  1080.                     gavewarning = .TRUE.
    1081. 

  1081.                   ENDIF
    1082. 

  1082.                   CALL get_fieldstr(4,':',inln,fieldlst,1024,noerr) ! get list of fields
    1083. 

  1083.                   IF ( noerr ) THEN
    1084. 

  1084.                     fieldno = 1
    1085. 

  1085.                     CALL get_fieldstr(fieldno,',',fieldlst,t1,256,noerr)
    1086. 

  1086.                     CALL change_to_lower_case(t1,lookee)
    1087. 

  1087.                     DO WHILE ( noerr )    ! linear search, blargh...
    1088. 

  1088.                       p => grid%head_statevars
    1089. 

  1089.                       found = .FALSE.
    1090. 

  1090.                       count_em = count_em + 1
    1091. 

  1091.                       DO WHILE ( ASSOCIATED( p ) )
    1092. 

  1092.   
    1093. 

  1093.                         IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
    1094. 

  1094.   
    1095. 

  1095.                           DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
    1096. 

  1096.                             CALL change_to_lower_case( p%dname_table( grid%id, itrace ) , dname ) 
    1097. 

  1097. 

  1098.                             IF ( TRIM(dname) .EQ. TRIM(lookee) ) &
    1099. 

  1099.                             CALL warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
    1100. 

  1100.                                                       strmtyp_name, dname, fname, lookee,      &
    1101. 

  1101.                                                       p%streams_table(grid%id,itrace)%stream,  &
    1102. 

  1102.                                                       mess, found, you_warned_me2)
    1103. 

  1103.                           ENDDO
    1104. 

  1104.                         ELSE 
    1105. 

  1105.                           IF ( p%Ntl .GT. 0 ) THEN
    1106. 

  1106.                             CALL change_to_lower_case(p%DataName(1:LEN(TRIM(p%DataName))-2),dname)
    1107. 

  1107.                           ELSE
    1108. 

  1108.                             CALL change_to_lower_case(p%DataName,dname)
    1109. 

  1109.                           ENDIF
    1110. 

  1110.   
    1111. 

  1111.                           IF ( TRIM(dname) .EQ. TRIM(lookee) ) &
    1112. 

  1112.                           CALL warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
    1113. 

  1113.                                                     strmtyp_name, dname, fname, lookee,      &
    1114. 

  1114.                                                     p%streams, mess, found, you_warned_me2)
    1115. 

  1115.                         ENDIF
    1116. 

  1116.                         p => p%next
    1117. 

  1117.                       ENDDO
    1118. 

  1118.                       IF ( .NOT. found ) THEN
    1119. 

  1119.                         WRITE(mess,*)'W A R N I N G : Unable to modify mask for ',TRIM(lookee),&
    1120. 

  1120.                                      '.  Variable not found. File: ',TRIM(fname),' at line ',lineno
    1121. 

  1121.                         CALL wrf_message(mess)
    1122. 

  1122.                         gavewarning = .TRUE.
    1123. 

  1123.                       ENDIF
    1124. 

  1124.                       fieldno = fieldno + 1
    1125. 

  1125.                       CALL get_fieldstr(fieldno,',',fieldlst,t1,256,noerr)
    1126. 

  1126.                       CALL change_to_lower_case(t1,lookee)
    1127. 

  1127.                     ENDDO
    1128. 

  1128.                   ELSE
    1129. 

  1129.                     WRITE(mess,*)'W A R N I N G : Problem reading ',TRIM(fname),' at line ',lineno
    1130. 

  1130.                     CALL wrf_message(mess)
    1131. 

  1131.                     gavewarning = .TRUE.
    1132. 

  1132.                   ENDIF
    1133. 

  1133.                 ENDIF  ! keepgoing
    1134. 

  1134.               ENDIF    ! skip comments
    1135. 

  1135.             ENDIF      ! keepgoing
    1136. 

  1136.           ENDDO
    1137. 

  1137.         ELSE
    1138. 

  1138.           WRITE(mess,*)'W A R N I N G : Problem opening ',TRIM(fname)
    1139. 

  1139.           CALL wrf_message(mess)
    1140. 

  1140.           gavewarning = .TRUE.
    1141. 

  1141.         ENDIF
    1142. 

  1142.         CLOSE( read_unit )
    1143. 

  1143.         IF ( gavewarning ) THEN
    1144. 

  1144.           CALL nl_get_ignore_iofields_warning(1,ignorewarning)
    1145. 

  1145.           IF ( .NOT. ignorewarning ) THEN
    1146. 

  1146.             CALL wrf_message(mess)
    1147. 

  1147.             WRITE(mess,*)'modify_io_masks: problems reading ',TRIM(fname) 
    1148. 

  1148.             CALL wrf_message(mess)
    1149. 

  1149.             CALL wrf_error_fatal('Set ignore_iofields_warn to true in namelist to ignore')
    1150. 

  1150.           ELSE
    1151. 

  1151.             IF ( .NOT. you_warned_me ) THEN
    1152. 

  1152.               if ( .NOT. you_warned_me2(count_em,id) ) CALL wrf_message(mess)  ! Don't repeat the W A R N I N G message
    1153. 

  1153.               WRITE(mess,*)'Ignoring problems reading ',TRIM(fname) 
    1154. 

  1154.               CALL wrf_message(mess)
    1155. 

  1155.               CALL wrf_message('Continuing.  To make this a fatal error, set ignore_iofields_warn to false in namelist' )
    1156. 

  1156.               CALL wrf_message(' ')
    1157. 

  1157.               you_warned_me = .TRUE.
    1158. 

  1158.             ENDIF
    1159. 

  1159.           ENDIF
    1160. 

  1160.         ENDIF
    1161. 

  1161.       ENDIF  ! wrf_dm_on_monitor
    1162. 

  1162. 

  1163. #ifdef DM_PARALLEL
    1164. 

  1164. ! broadcast the new masks to the other tasks
    1165. 

  1165.       p => grid%head_statevars
    1166. 

  1166.       DO WHILE ( ASSOCIATED( p ) )
    1167. 

  1167.         IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
    1168. 

  1168. 

  1169.           DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
    1170. 

  1170.             CALL wrf_dm_bcast_integer( p%streams_table(grid%id,itrace)%stream, IO_MASK_SIZE )
    1171. 

  1171.           ENDDO
    1172. 

  1172. 

  1173.         ELSE
    1174. 

  1174.           CALL wrf_dm_bcast_integer( p%streams, IO_MASK_SIZE )
    1175. 

  1175.         ENDIF
    1176. 

  1176.         p => p%next
    1177. 

  1177.       ENDDO
    1178. 

  1178. #endif
    1179. 

  1179.       
    1180. 

  1180.    END SUBROUTINE modify_io_masks1
    1181. 

  1181. 

  1182.    SUBROUTINE warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
    1183. 

  1183.                                    strmtyp_name, dname, fname, lookee,      &
    1184. 

  1184.                                    p_stream, mess, found, you_warned_me2)
    1185. 

  1185. 

  1186.       IMPLICIT NONE
    1187. 

  1187. 

  1188. ! See if a field that is requested to be added to or removed from the I/O stream
    1189. 

  1189. !    is already present or absent
    1190. 

  1190. ! If the requested action has already been done, write a warning message
    1191. 

  1191. ! If not, satisfy the request
    1192. 

  1192. 

  1193.      INTEGER,       INTENT(IN )   :: id, istrm, lineno, strmtyp_int
    1194. 

  1194.      INTEGER,       INTENT(IN )   :: p_stream(*), count_em
    1195. 

  1195.      CHARACTER*1,   INTENT(IN )   :: op
    1196. 

  1196.      CHARACTER*10,  INTENT(IN )   :: strmtyp_name
    1197. 

  1197.      CHARACTER*256, INTENT(IN )   :: dname, fname, lookee
    1198. 

  1198.      CHARACTER*256, INTENT(OUT)   :: mess
    1199. 

  1199.      LOGICAL,       INTENT(OUT)   :: found
    1200. 

  1200.      LOGICAL,       INTENT(INOUT) :: you_warned_me2(max_hst_mods,max_domains)
    1201. 

  1201.    ! Local
    1202. 

  1202.      INTEGER                      :: retval
    1203. 

  1203. 

  1204.      found = .TRUE.
    1205. 

  1205.      IF      ( TRIM(op) .EQ. '+' ) THEN
    1206. 

  1206.        CALL get_mask( p_stream, strmtyp_int + istrm - 1, retval )
    1207. 

  1207.        IF ( retval .NE. 0 ) THEN
    1208. 

  1208.          WRITE(mess,*) 'Domain ',id, ' W A R N I N G : Variable ',TRIM(lookee),' already on ', &
    1209. 

  1209.                        TRIM(strmtyp_name), ' stream ',istrm, '.  File: ', TRIM(fname),' at line ',lineno
    1210. 

  1210.        ELSE
    1211. 

  1211.          WRITE(mess,*) 'Domain ', id, ' Setting ', TRIM(strmtyp_name), ' stream ',istrm,' for ', &
    1212. 

  1212.                                   TRIM(DNAME)  ; CALL wrf_debug(1,mess)
    1213. 

  1213.          CALL set_mask( p_stream, strmtyp_int + istrm - 1 )
    1214. 

  1214.        ENDIF
    1215. 

  1215.      ELSE IF ( TRIM(op) .EQ. '-' ) THEN
    1216. 

  1216.        CALL get_mask( p_stream, strmtyp_int + istrm - 1, retval )
    1217. 

  1217.        IF ( retval .EQ. 0 ) THEN
    1218. 

  1218.          WRITE(mess,*) 'Domain ',id, ' W A R N I N G : Variable ',TRIM(lookee),' already off ', &
    1219. 

  1219.                        TRIM(strmtyp_name), ' stream ',istrm, '. File: ',TRIM(fname),' at line ',lineno
    1220. 

  1220.        ELSE
    1221. 

  1221.          WRITE(mess,*) 'Domain ', id, ' Resetting ', TRIM(strmtyp_name), ' stream ',istrm,' for ', &
    1222. 

  1222.                                     TRIM(DNAME)  ; CALL wrf_debug(1,mess) 
    1223. 

  1223.          CALL reset_mask( p_stream, strmtyp_int + istrm - 1)
    1224. 

  1224.        ENDIF
    1225. 

  1225.      ENDIF
    1226. 

  1226.      IF ( count_em > max_hst_mods ) THEN
    1227. 

  1227.        WRITE(mess,*)'ERROR module_domain:  Array size for you_warned_me2 is fixed at ',max_hst_mods
    1228. 

  1228.        CALL wrf_message(mess)
    1229. 

  1229.        CALL wrf_error_fatal('Did you really type > max_hst_mods fields into ', TRIM(fname) ,' ?')
    1230. 

  1230.      ELSE
    1231. 

  1231.        IF ( .NOT. you_warned_me2(count_em,id) ) THEN
    1232. 

  1232.          CALL wrf_message(mess)     ! Write warning message once for each field
    1233. 

  1233.          you_warned_me2(count_em,id) = .TRUE.
    1234. 

  1234.        ENDIF
    1235. 

  1235.      ENDIF
    1236. 

  1236. 

  1237.    END SUBROUTINE warn_me_or_set_mask 
    1238. 

  1238. 

  1239. !  This routine ALLOCATEs the required space for the meteorological fields
    1240. 

  1240. !  for a specific domain.  The fields are simply ALLOCATEd as an -1.  They
    1241. 

  1241. !  are referenced as wind, temperature, moisture, etc. in routines that are
    1242. 

  1242. !  below this top-level of data allocation and management (in the solve routine
    1243. 

  1243. !  and below).
    1244. 

  1244. 

  1245.    SUBROUTINE alloc_space_field ( grid,   id, setinitval_in ,  tl_in , inter_domain_in ,   &
    1246. 

  1246.                                   sd31, ed31, sd32, ed32, sd33, ed33, &
    1247. 

  1247.                                   sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1248. 

  1248.                                   sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1249. 

  1249.                                   sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1250. 

  1250.                                   sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1251. 

  1251.                                   sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1252. 

  1252.                                   sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1253. 

  1253. 

  1254.       USE module_alloc_space_0, ONLY : alloc_space_field_core_0
    1255. 

  1255.       USE module_alloc_space_1, ONLY : alloc_space_field_core_1
    1256. 

  1256.       USE module_alloc_space_2, ONLY : alloc_space_field_core_2
    1257. 

  1257.       USE module_alloc_space_3, ONLY : alloc_space_field_core_3
    1258. 

  1258.       USE module_alloc_space_4, ONLY : alloc_space_field_core_4
    1259. 

  1259.       USE module_alloc_space_5, ONLY : alloc_space_field_core_5
    1260. 

  1260.       USE module_alloc_space_6, ONLY : alloc_space_field_core_6
    1261. 

  1261.       USE module_alloc_space_7, ONLY : alloc_space_field_core_7
    1262. 

  1262.       USE module_alloc_space_8, ONLY : alloc_space_field_core_8
    1263. 

  1263.       USE module_alloc_space_9, ONLY : alloc_space_field_core_9
    1264. 

  1264. 

  1265.       IMPLICIT NONE
    1266. 

  1266. 

  1267.       !  Input data.
    1268. 

  1268. 

  1269.       TYPE(domain)               , POINTER          :: grid
    1270. 

  1270.       INTEGER , INTENT(IN)            :: id
    1271. 

  1271.       INTEGER , INTENT(IN)            :: setinitval_in   ! 3 = everything, 1 = arrays only, 0 = none
    1272. 

  1272.       INTEGER , INTENT(IN)            :: sd31, ed31, sd32, ed32, sd33, ed33
    1273. 

  1273.       INTEGER , INTENT(IN)            :: sm31, em31, sm32, em32, sm33, em33
    1274. 

  1274.       INTEGER , INTENT(IN)            :: sp31, ep31, sp32, ep32, sp33, ep33
    1275. 

  1275.       INTEGER , INTENT(IN)            :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x
    1276. 

  1276.       INTEGER , INTENT(IN)            :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y
    1277. 

  1277.       INTEGER , INTENT(IN)            :: sm31x, em31x, sm32x, em32x, sm33x, em33x
    1278. 

  1278.       INTEGER , INTENT(IN)            :: sm31y, em31y, sm32y, em32y, sm33y, em33y
    1279. 

  1279. 

  1280.       ! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.
    1281. 

  1281.       ! e.g. to set both 1st and second time level, use 3
    1282. 

  1282.       !      to set only 1st                        use 1
    1283. 

  1283.       !      to set only 2st                        use 2
    1284. 

  1284.       INTEGER , INTENT(IN)            :: tl_in
    1285. 

  1285.   
    1286. 

  1286.       ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated
    1287. 

  1287.       ! false otherwise (all allocated, modulo tl above)
    1288. 

  1288.       LOGICAL , INTENT(IN)            :: inter_domain_in
    1289. 

  1289. 

  1290.       ! Local
    1291. 

  1291.       INTEGER(KIND=8)  num_bytes_allocated
    1292. 

  1292.       INTEGER  idum1, idum2
    1293. 

  1293. 

  1294. #if (EM_CORE == 1)
    1295. 

  1295.       IF ( grid%id .EQ. 1 ) CALL wrf_message ( &
    1296. 

  1296.           'DYNAMICS OPTION: Eulerian Mass Coordinate ')
    1297. 

  1297. #endif
    1298. 

  1298. #if (NMM_CORE == 1)
    1299. 

  1299.       IF ( grid%id .EQ. 1 ) &
    1300. 

  1300.           CALL wrf_message ( 'DYNAMICS OPTION: nmm dyncore' )
    1301. 

  1301. #endif
    1302. 

  1302. #if (COAMPS_CORE == 1)
    1303. 

  1303.         IF ( grid%id .EQ. 1 ) &
    1304. 

  1304.           CALL wrf_message ( 'DYNAMICS OPTION: coamps dyncore' )
    1305. 

  1305. #endif
    1306. 

  1306. 

  1307.       CALL set_scalar_indices_from_config( id , idum1 , idum2 )
    1308. 

  1308. 

  1309.       num_bytes_allocated = 0 
    1310. 

  1310. 

  1311.       ! now separate modules to reduce the size of module_domain that the compiler sees
    1312. 

  1312.       CALL alloc_space_field_core_0 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated , &
    1313. 

  1313.                                     sd31, ed31, sd32, ed32, sd33, ed33, &
    1314. 

  1314.                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1315. 

  1315.                                     sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1316. 

  1316.                                     sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1317. 

  1317.                                     sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1318. 

  1318.                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1319. 

  1319.                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1320. 

  1320.       CALL alloc_space_field_core_1 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
    1321. 

  1321.                                     sd31, ed31, sd32, ed32, sd33, ed33, &
    1322. 

  1322.                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1323. 

  1323.                                     sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1324. 

  1324.                                     sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1325. 

  1325.                                     sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1326. 

  1326.                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1327. 

  1327.                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1328. 

  1328.       CALL alloc_space_field_core_2 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
    1329. 

  1329.                                     sd31, ed31, sd32, ed32, sd33, ed33, &
    1330. 

  1330.                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1331. 

  1331.                                     sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1332. 

  1332.                                     sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1333. 

  1333.                                     sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1334. 

  1334.                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1335. 

  1335.                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1336. 

  1336.       CALL alloc_space_field_core_3 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
    1337. 

  1337.                                     sd31, ed31, sd32, ed32, sd33, ed33, &
    1338. 

  1338.                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1339. 

  1339.                                     sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1340. 

  1340.                                     sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1341. 

  1341.                                     sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1342. 

  1342.                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1343. 

  1343.                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1344. 

  1344.       CALL alloc_space_field_core_4 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
    1345. 

  1345.                                     sd31, ed31, sd32, ed32, sd33, ed33, &
    1346. 

  1346.                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1347. 

  1347.                                     sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1348. 

  1348.                                     sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1349. 

  1349.                                     sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1350. 

  1350.                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1351. 

  1351.                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1352. 

  1352.       CALL alloc_space_field_core_5 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
    1353. 

  1353.                                     sd31, ed31, sd32, ed32, sd33, ed33, &
    1354. 

  1354.                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1355. 

  1355.                                     sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1356. 

  1356.                                     sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1357. 

  1357.                                     sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1358. 

  1358.                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1359. 

  1359.                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1360. 

  1360.       CALL alloc_space_field_core_6 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
    1361. 

  1361.                                     sd31, ed31, sd32, ed32, sd33, ed33, &
    1362. 

  1362.                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1363. 

  1363.                                     sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1364. 

  1364.                                     sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1365. 

  1365.                                     sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1366. 

  1366.                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1367. 

  1367.                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1368. 

  1368.       CALL alloc_space_field_core_7 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
    1369. 

  1369.                                     sd31, ed31, sd32, ed32, sd33, ed33, &
    1370. 

  1370.                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1371. 

  1371.                                     sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1372. 

  1372.                                     sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1373. 

  1373.                                     sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1374. 

  1374.                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1375. 

  1375.                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1376. 

  1376.       CALL alloc_space_field_core_8 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
    1377. 

  1377.                                     sd31, ed31, sd32, ed32, sd33, ed33, &
    1378. 

  1378.                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1379. 

  1379.                                     sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1380. 

  1380.                                     sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1381. 

  1381.                                     sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1382. 

  1382.                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1383. 

  1383.                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1384. 

  1384.       CALL alloc_space_field_core_9 ( grid,   id, setinitval_in ,  tl_in , inter_domain_in , num_bytes_allocated ,  &
    1385. 

  1385.                                     sd31, ed31, sd32, ed32, sd33, ed33, &
    1386. 

  1386.                                     sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1387. 

  1387.                                     sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1388. 

  1388.                                     sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1389. 

  1389.                                     sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1390. 

  1390.                                     sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1391. 

  1391.                                     sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1392. 

  1392. 

  1393.       IF ( .NOT. grid%have_displayed_alloc_stats ) THEN
    1394. 

  1394.         ! we do not want to see this message more than once, as can happen with the allocation and
    1395. 

  1395.         ! deallocation of intermediate domains used in nesting.
    1396. 

  1396.         WRITE(wrf_err_message,*)&
    1397. 

  1397.             'alloc_space_field: domain ',id,', ',num_bytes_allocated,' bytes allocated'
    1398. 

  1398.         CALL  wrf_debug( 0, wrf_err_message )
    1399. 

  1399.         grid%have_displayed_alloc_stats = .TRUE.   
    1400. 

  1400.       ENDIF
    1401. 

  1401. 

  1402. 

  1403.       grid%alloced_sd31=sd31
    1404. 

  1404.       grid%alloced_ed31=ed31
    1405. 

  1405.       grid%alloced_sd32=sd32
    1406. 

  1406.       grid%alloced_ed32=ed32
    1407. 

  1407.       grid%alloced_sd33=sd33
    1408. 

  1408.       grid%alloced_ed33=ed33
    1409. 

  1409.       grid%alloced_sm31=sm31
    1410. 

  1410.       grid%alloced_em31=em31
    1411. 

  1411.       grid%alloced_sm32=sm32
    1412. 

  1412.       grid%alloced_em32=em32
    1413. 

  1413.       grid%alloced_sm33=sm33
    1414. 

  1414.       grid%alloced_em33=em33
    1415. 

  1415.       grid%alloced_sm31x=sm31x
    1416. 

  1416.       grid%alloced_em31x=em31x
    1417. 

  1417.       grid%alloced_sm32x=sm32x
    1418. 

  1418.       grid%alloced_em32x=em32x
    1419. 

  1419.       grid%alloced_sm33x=sm33x
    1420. 

  1420.       grid%alloced_em33x=em33x
    1421. 

  1421.       grid%alloced_sm31y=sm31y
    1422. 

  1422.       grid%alloced_em31y=em31y
    1423. 

  1423.       grid%alloced_sm32y=sm32y
    1424. 

  1424.       grid%alloced_em32y=em32y
    1425. 

  1425.       grid%alloced_sm33y=sm33y
    1426. 

  1426.       grid%alloced_em33y=em33y
    1427. 

  1427. 

  1428.       grid%allocated=.TRUE.
    1429. 

  1429. 

  1430.    END SUBROUTINE alloc_space_field
    1431. 

  1431. 

  1432.    ! Ensure_space_field allocates a grid's arrays if they are not yet
    1433. 

  1433.    ! allocated.  If they were already allocated, then it deallocates and
    1434. 

  1434.    ! reallocates them if they were allocated with different dimensions.
    1435. 

  1435.    ! If they were already allocated with the requested dimensions, then
    1436. 

  1436.    ! ensure_space_field does nothing.
    1437. 

  1437. 

  1438.    SUBROUTINE ensure_space_field ( grid,   id, setinitval_in ,  tl_in , inter_domain_in ,   &
    1439. 

  1439.                                   sd31, ed31, sd32, ed32, sd33, ed33, &
    1440. 

  1440.                                   sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1441. 

  1441.                                   sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1442. 

  1442.                                   sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1443. 

  1443.                                   sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1444. 

  1444.                                   sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1445. 

  1445.                                   sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1446. 

  1446. 

  1447.       IMPLICIT NONE
    1448. 

  1448. 

  1449.       !  Input data.
    1450. 

  1450. 

  1451.       TYPE(domain)               , POINTER          :: grid
    1452. 

  1452.       INTEGER , INTENT(IN)            :: id
    1453. 

  1453.       INTEGER , INTENT(IN)            :: setinitval_in   ! 3 = everything, 1 = arrays only, 0 = none
    1454. 

  1454.       INTEGER , INTENT(IN)            :: sd31, ed31, sd32, ed32, sd33, ed33
    1455. 

  1455.       INTEGER , INTENT(IN)            :: sm31, em31, sm32, em32, sm33, em33
    1456. 

  1456.       INTEGER , INTENT(IN)            :: sp31, ep31, sp32, ep32, sp33, ep33
    1457. 

  1457.       INTEGER , INTENT(IN)            :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x
    1458. 

  1458.       INTEGER , INTENT(IN)            :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y
    1459. 

  1459.       INTEGER , INTENT(IN)            :: sm31x, em31x, sm32x, em32x, sm33x, em33x
    1460. 

  1460.       INTEGER , INTENT(IN)            :: sm31y, em31y, sm32y, em32y, sm33y, em33y
    1461. 

  1461. 

  1462.       ! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.
    1463. 

  1463.       ! e.g. to set both 1st and second time level, use 3
    1464. 

  1464.       !      to set only 1st                        use 1
    1465. 

  1465.       !      to set only 2st                        use 2
    1466. 

  1466.       INTEGER , INTENT(IN)            :: tl_in
    1467. 

  1467.   
    1468. 

  1468.       ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated
    1469. 

  1469.       ! false otherwise (all allocated, modulo tl above)
    1470. 

  1470.       LOGICAL , INTENT(IN)            :: inter_domain_in
    1471. 

  1471.       LOGICAL                         :: size_changed
    1472. 

  1472. 

  1473.       size_changed=         .not. ( &
    1474. 

  1474.          grid%alloced_sd31 .eq. sd31 .and. grid%alloced_ed31 .eq. ed31 .and. &
    1475. 

  1475.          grid%alloced_sd32 .eq. sd32 .and. grid%alloced_ed32 .eq. ed32 .and. &
    1476. 

  1476.          grid%alloced_sd33 .eq. sd33 .and. grid%alloced_ed33 .eq. ed33 .and. &
    1477. 

  1477.          grid%alloced_sm31 .eq. sm31 .and. grid%alloced_em31 .eq. em31 .and. &
    1478. 

  1478.          grid%alloced_sm32 .eq. sm32 .and. grid%alloced_em32 .eq. em32 .and. &
    1479. 

  1479.          grid%alloced_sm33 .eq. sm33 .and. grid%alloced_em33 .eq. em33 .and. &
    1480. 

  1480.          grid%alloced_sm31x .eq. sm31x .and. grid%alloced_em31x .eq. em31x .and. &
    1481. 

  1481.          grid%alloced_sm32x .eq. sm32x .and. grid%alloced_em32x .eq. em32x .and. &
    1482. 

  1482.          grid%alloced_sm33x .eq. sm33x .and. grid%alloced_em33x .eq. em33x .and. &
    1483. 

  1483.          grid%alloced_sm31y .eq. sm31y .and. grid%alloced_em31y .eq. em31y .and. &
    1484. 

  1484.          grid%alloced_sm32y .eq. sm32y .and. grid%alloced_em32y .eq. em32y .and. &
    1485. 

  1485.          grid%alloced_sm33y .eq. sm33y .and. grid%alloced_em33y .eq. em33y &
    1486. 

  1486.       )
    1487. 

  1487.       if(.not. grid%allocated .or. size_changed) then
    1488. 

  1488.          if(.not. grid%allocated) then
    1489. 

  1489.             call wrf_debug(1,'ensure_space_field: calling alloc_space_field because a grid was not allocated.')
    1490. 

  1490.          else
    1491. 

  1491.             if(size_changed) &
    1492. 

  1492.                  call wrf_debug(1,'ensure_space_field: deallocating and reallocating a grid because grid size changed.')
    1493. 

  1493.          end if
    1494. 

  1494.          if(grid%allocated) &
    1495. 

  1495.               call dealloc_space_field( grid )
    1496. 

  1496.          call alloc_space_field ( grid,   id, setinitval_in ,  tl_in , inter_domain_in ,   &
    1497. 

  1497.                                   sd31, ed31, sd32, ed32, sd33, ed33, &
    1498. 

  1498.                                   sm31 , em31 , sm32 , em32 , sm33 , em33 , &
    1499. 

  1499.                                   sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
    1500. 

  1500.                                   sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
    1501. 

  1501.                                   sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
    1502. 

  1502.                                   sm31x, em31x, sm32x, em32x, sm33x, em33x, &
    1503. 

  1503.                                   sm31y, em31y, sm32y, em32y, sm33y, em33y )
    1504. 

  1504.       end if
    1505. 

  1505. 

  1506.    END SUBROUTINE ensure_space_field
    1507. 

  1507. 

  1508. !  This routine is used to DEALLOCATE space for a single domain and remove 
    1509. 

  1509. !  it from the linked list.  First the pointers in the linked list are fixed 
    1510. 

  1510. !  (so the one in the middle can be removed).  Then the domain itself is 
    1511. 

  1511. !  DEALLOCATEd via a call to domain_destroy().  
    1512. 

  1512. 

  1513.    SUBROUTINE dealloc_space_domain ( id )
    1514. 

  1514.       
    1515. 

  1515.       IMPLICIT NONE
    1516. 

  1516. 

  1517.       !  Input data.
    1518. 

  1518. 

  1519.       INTEGER , INTENT(IN)            :: id
    1520. 

  1520. 

  1521.       !  Local data.
    1522. 

  1522. 

  1523.       TYPE(domain) , POINTER          :: grid
    1524. 

  1524.       LOGICAL                         :: found
    1525. 

  1525. 

  1526.       !  Initializations required to start the routine.
    1527. 

  1527. 

  1528.       grid => head_grid
    1529. 

  1529.       old_grid => head_grid
    1530. 

  1530.       found = .FALSE.
    1531. 

  1531. 

  1532.       !  The identity of the domain to delete is based upon the "id".
    1533. 

  1533.       !  We search all of the possible grids.  It is required to find a domain
    1534. 

  1534.       !  otherwise it is a fatal error.  
    1535. 

  1535. 

  1536.       find_grid : DO WHILE ( ASSOCIATED(grid) ) 
    1537. 

  1537.          IF ( grid%id == id ) THEN
    1538. 

  1538.             found = .TRUE.
    1539. 

  1539.             old_grid%next => grid%next
    1540. 

  1540.             CALL domain_destroy( grid )
    1541. 

  1541.             EXIT find_grid
    1542. 

  1542.          END IF
    1543. 

  1543.          old_grid => grid
    1544. 

  1544.          grid     => grid%next
    1545. 

  1545.       END DO find_grid
    1546. 

  1546. 

  1547.       IF ( .NOT. found ) THEN
    1548. 

  1548.          WRITE ( wrf_err_message , * ) 'module_domain: ', &
    1549. 

  1549.            'dealloc_space_domain: Could not de-allocate grid id ',id
    1550. 

  1550.          CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) 
    1551. 

  1551.       END IF
    1552. 

  1552. 

  1553.    END SUBROUTINE dealloc_space_domain
    1554. 

  1554. 

  1555. 

  1556. 

  1557. !  This routine is used to DEALLOCATE space for a single domain type.  
    1558. 

  1558. !  First, the field data are all removed through a CALL to the 
    1559. 

  1559. !  dealloc_space_field routine.  Then the pointer to the domain
    1560. 

  1560. !  itself is DEALLOCATEd.
    1561. 

  1561. 

  1562.    SUBROUTINE domain_destroy ( grid )
    1563. 

  1563.       
    1564. 

  1564.       IMPLICIT NONE
    1565. 

  1565. 

  1566.       !  Input data.
    1567. 

  1567. 

  1568.       TYPE(domain) , POINTER          :: grid
    1569. 

  1569. 

  1570.       CALL dealloc_space_field ( grid )
    1571. 

  1571.       CALL dealloc_linked_lists( grid )
    1572. 

  1572.       DEALLOCATE( grid%parents )
    1573. 

  1573.       DEALLOCATE( grid%nests )
    1574. 

  1574.       ! clean up time manager bits
    1575. 

  1575.       CALL domain_clock_destroy( grid )
    1576. 

  1576.       CALL domain_alarms_destroy( grid )
    1577. 

  1577.       IF ( ASSOCIATED( grid%i_start ) ) THEN
    1578. 

  1578.         DEALLOCATE( grid%i_start ) 
    1579. 

  1579.       ENDIF
    1580. 

  1580.       IF ( ASSOCIATED( grid%i_end ) ) THEN
    1581. 

  1581.         DEALLOCATE( grid%i_end )
    1582. 

  1582.       ENDIF
    1583. 

  1583.       IF ( ASSOCIATED( grid%j_start ) ) THEN
    1584. 

  1584.         DEALLOCATE( grid%j_start )
    1585. 

  1585.       ENDIF
    1586. 

  1586.       IF ( ASSOCIATED( grid%j_end ) ) THEN
    1587. 

  1587.         DEALLOCATE( grid%j_end )
    1588. 

  1588.       ENDIF
    1589. 

  1589.       IF ( ASSOCIATED( grid%itsloc ) ) THEN
    1590. 

  1590.         DEALLOCATE( grid%itsloc )
    1591. 

  1591.       ENDIF 
    1592. 

  1592.       IF ( ASSOCIATED( grid%jtsloc ) ) THEN
    1593. 

  1593.         DEALLOCATE( grid%jtsloc )
    1594. 

  1594.       ENDIF 
    1595. 

  1595.       IF ( ASSOCIATED( grid%id_tsloc ) ) THEN
    1596. 

  1596.         DEALLOCATE( grid%id_tsloc )
    1597. 

  1597.       ENDIF 
    1598. 

  1598.       IF ( ASSOCIATED( grid%lattsloc ) ) THEN
    1599. 

  1599.         DEALLOCATE( grid%lattsloc )
    1600. 

  1600.       ENDIF 
    1601. 

  1601.       IF ( ASSOCIATED( grid%lontsloc ) ) THEN
    1602. 

  1602.         DEALLOCATE( grid%lontsloc )
    1603. 

  1603.       ENDIF 
    1604. 

  1604.       IF ( ASSOCIATED( grid%nametsloc ) ) THEN
    1605. 

  1605.         DEALLOCATE( grid%nametsloc )
    1606. 

  1606.       ENDIF 
    1607. 

  1607.       IF ( ASSOCIATED( grid%desctsloc ) ) THEN
    1608. 

  1608.         DEALLOCATE( grid%desctsloc )
    1609. 

  1609.       ENDIF 
    1610. 

  1610.       IF ( ASSOCIATED( grid%ts_filename ) ) THEN
    1611. 

  1611.         DEALLOCATE( grid%ts_filename )
    1612. 

  1612.       ENDIF 
    1613. 

  1613. #if (EM_CORE == 1)
    1614. 

  1614.       IF ( ASSOCIATED( grid%track_time_in ) ) THEN
    1615. 

  1615.         DEALLOCATE( grid%track_time_in )
    1616. 

  1616.       ENDIF
    1617. 

  1617.  
    1618. 

  1618.       IF ( ASSOCIATED( grid%track_lat_in ) ) THEN
    1619. 

  1619.         DEALLOCATE( grid%track_lat_in )
    1620. 

  1620.       ENDIF
    1621. 

  1621.  
    1622. 

  1622.       IF ( ASSOCIATED( grid%track_lon_in ) ) THEN
    1623. 

  1623.         DEALLOCATE( grid%track_lon_in )
    1624. 

  1624.       ENDIF
    1625. 

  1625.  
    1626. 

  1626.       IF ( ASSOCIATED( grid%track_i ) ) THEN
    1627. 

  1627.         DEALLOCATE( grid%track_i )
    1628. 

  1628.       ENDIF
    1629. 

  1629.  
    1630. 

  1630.       IF ( ASSOCIATED( grid%track_j ) ) THEN
    1631. 

  1631.         DEALLOCATE( grid%track_j )
    1632. 

  1632.       ENDIF
    1633. 

  1633. 

  1634.       IF ( ASSOCIATED( grid%track_time_domain ) ) THEN
    1635. 

  1635.         DEALLOCATE( grid%track_time_domain )
    1636. 

  1636.       ENDIF
    1637. 

  1637.  
    1638. 

  1638.       IF ( ASSOCIATED( grid%track_lat_domain ) ) THEN
    1639. 

  1639.         DEALLOCATE( grid%track_lat_domain )
    1640. 

  1640.       ENDIF
    1641. 

  1641.  
    1642. 

  1642.       IF ( ASSOCIATED( grid%track_lon_domain ) ) THEN
    1643. 

  1643.         DEALLOCATE( grid%track_lon_domain )
    1644. 

  1644.       ENDIF
    1645. 

  1645. #endif
    1646. 

  1646.       DEALLOCATE( grid )
    1647. 

  1647.       NULLIFY( grid )
    1648. 

  1648. 

  1649.    END SUBROUTINE domain_destroy
    1650. 

  1650. 

  1651.    SUBROUTINE dealloc_linked_lists ( grid )
    1652. 

  1652.       IMPLICIT NONE
    1653. 

  1653.       TYPE(domain), POINTER :: grid
    1654. 

  1654.       TYPE(fieldlist), POINTER :: p, q
    1655. 

  1655.       p => grid%head_statevars
    1656. 

  1656.       DO WHILE ( ASSOCIATED( p ) )
    1657. 

  1657.          q => p ; p => p%next ; DEALLOCATE(q)
    1658. 

  1658.       ENDDO
    1659. 

  1659.       NULLIFY(grid%head_statevars) ; NULLIFY( grid%tail_statevars)
    1660. 

  1660. #if (DA_CORE != 1)
    1661. 

  1661.       IF ( .NOT. grid%is_intermediate ) THEN
    1662. 

  1662.         ALLOCATE( grid%head_statevars )
    1663. 

  1663.         NULLIFY( grid%head_statevars%next)
    1664. 

  1664.         grid%tail_statevars => grid%head_statevars
    1665. 

  1665.       ENDIF
    1666. 

  1666. #endif
    1667. 

  1667.    END SUBROUTINE dealloc_linked_lists
    1668. 

  1668. 

  1669.    RECURSIVE SUBROUTINE show_nest_subtree ( grid )
    1670. 

  1670.       TYPE(domain), POINTER :: grid
    1671. 

  1671.       INTEGER myid
    1672. 

  1672.       INTEGER kid
    1673. 

  1673.       IF ( .NOT. ASSOCIATED( grid ) ) RETURN
    1674. 

  1674.       myid = grid%id
    1675. 

  1675.       write(0,*)'show_nest_subtree ',myid
    1676. 

  1676.       DO kid = 1, max_nests
    1677. 

  1677.         IF ( ASSOCIATED( grid%nests(kid)%ptr ) ) THEN
    1678. 

  1678.           IF ( grid%nests(kid)%ptr%id .EQ. myid ) THEN
    1679. 

  1679.             CALL wrf_error_fatal( 'show_nest_subtree: nest hierarchy corrupted' )
    1680. 

  1680.           ENDIF
    1681. 

  1681.           CALL show_nest_subtree( grid%nests(kid)%ptr )
    1682. 

  1682.         ENDIF
    1683. 

  1683.       ENDDO
    1684. 

  1684.    END SUBROUTINE show_nest_subtree
    1685. 

  1685.    
    1686. 

  1686. 

  1687. !
    1688. 

  1688. 

  1689. !  This routine DEALLOCATEs each gridded field for this domain.  For each type of
    1690. 

  1690. !  different array (1d, 2d, 3d, etc.), the space for each pointer is DEALLOCATEd
    1691. 

  1691. !  for every -1 (i.e., each different meteorological field).
    1692. 

  1692. 

  1693.    SUBROUTINE dealloc_space_field ( grid )
    1694. 

  1694.       
    1695. 

  1695.       IMPLICIT NONE
    1696. 

  1696. 

  1697.       !  Input data.
    1698. 

  1698. 

  1699.       TYPE(domain)              , POINTER :: grid
    1700. 

  1700. 

  1701.       !  Local data.
    1702. 

  1702. 

  1703.       INTEGER                             ::  ierr
    1704. 

  1704. 

  1705. # include <deallocs.inc>
    1706. 

  1706. 

  1707.    END SUBROUTINE dealloc_space_field
    1708. 

  1708. 

  1709. !
    1710. 

  1710. !
    1711. 

  1711.    RECURSIVE SUBROUTINE find_grid_by_id ( id, in_grid, result_grid )
    1712. 

  1712.       IMPLICIT NONE
    1713. 

  1713.       INTEGER, INTENT(IN) :: id
    1714. 

  1714.       TYPE(domain), POINTER     :: in_grid 
    1715. 

  1715.       TYPE(domain), POINTER     :: result_grid
    1716. 

  1716. ! <DESCRIPTION>
    1717. 

  1717. ! This is a recursive subroutine that traverses the domain hierarchy rooted
    1718. 

  1718. ! at the input argument <em>in_grid</em>, a pointer to TYPE(domain), and returns
    1719. 

  1719. ! a pointer to the domain matching the integer argument <em>id</em> if it exists.
    1720. 

  1720. !
    1721. 

  1721. ! </DESCRIPTION>
    1722. 

  1722.       TYPE(domain), POINTER     :: grid_ptr
    1723. 

  1723.       INTEGER                   :: kid
    1724. 

  1724.       LOGICAL                   :: found
    1725. 

  1725.       found = .FALSE.
    1726. 

  1726.       NULLIFY(result_grid)
    1727. 

  1727.       IF ( ASSOCIATED( in_grid ) ) THEN
    1728. 

  1728.         IF ( in_grid%id .EQ. id ) THEN
    1729. 

  1729.            result_grid => in_grid
    1730. 

  1730.         ELSE
    1731. 

  1731.            grid_ptr => in_grid
    1732. 

  1732.            DO WHILE ( ASSOCIATED( grid_ptr ) .AND. .NOT. found )
    1733. 

  1733.               DO kid = 1, max_nests
    1734. 

  1734.                  IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) .AND. .NOT. found ) THEN
    1735. 

  1735.                     CALL find_grid_by_id ( id, grid_ptr%nests(kid)%ptr, result_grid )
    1736. 

  1736.                     IF ( ASSOCIATED( result_grid ) ) THEN
    1737. 

  1737.                       IF ( result_grid%id .EQ. id ) found = .TRUE.
    1738. 

  1738.                     ENDIF
    1739. 

  1739.                  ENDIF
    1740. 

  1740.               ENDDO
    1741. 

  1741.               IF ( .NOT. found ) grid_ptr => grid_ptr%sibling
    1742. 

  1742.            ENDDO
    1743. 

  1743.         ENDIF
    1744. 

  1744.       ENDIF
    1745. 

  1745.       RETURN
    1746. 

  1746.    END SUBROUTINE find_grid_by_id
    1747. 

  1747. 

  1748. 

  1749.    FUNCTION first_loc_integer ( array , search ) RESULT ( loc ) 
    1750. 

  1750.  
    1751. 

  1751.       IMPLICIT NONE
    1752. 

  1752. 

  1753.       !  Input data.
    1754. 

  1754. 

  1755.       INTEGER , INTENT(IN) , DIMENSION(:) :: array
    1756. 

  1756.       INTEGER , INTENT(IN)                :: search
    1757. 

  1757. 

  1758.       !  Output data.
    1759. 

  1759. 

  1760.       INTEGER                             :: loc
    1761. 

  1761. 

  1762. !<DESCRIPTION>
    1763. 

  1763. !  This routine is used to find a specific domain identifier in an array
    1764. 

  1764. !  of domain identifiers.
    1765. 

  1765. !
    1766. 

  1766. !</DESCRIPTION>
    1767. 

  1767.       
    1768. 

  1768.       !  Local data.
    1769. 

  1769. 

  1770.       INTEGER :: loop
    1771. 

  1771. 

  1772.       loc = -1
    1773. 

  1773.       find : DO loop = 1 , SIZE(array)
    1774. 

  1774.          IF ( search == array(loop) ) THEN         
    1775. 

  1775.             loc = loop
    1776. 

  1776.             EXIT find
    1777. 

  1777.          END IF
    1778. 

  1778.       END DO find
    1779. 

  1779. 

  1780.    END FUNCTION first_loc_integer
    1781. 

  1781. !
    1782. 

  1782.    SUBROUTINE init_module_domain
    1783. 

  1783.    END SUBROUTINE init_module_domain
    1784. 

  1784. 

  1785. 

  1786. ! <DESCRIPTION>
    1787. 

  1787. !
    1788. 

  1788. ! The following routines named domain_*() are convenience routines that 
    1789. 

  1789. ! eliminate many duplicated bits of code.  They provide shortcuts for the 
    1790. 

  1790. ! most common operations on the domain_clock field of TYPE(domain).  
    1791. 

  1791. !
    1792. 

  1792. ! </DESCRIPTION>
    1793. 

  1793. 

  1794.       FUNCTION domain_get_current_time ( grid ) RESULT ( current_time ) 
    1795. 

  1795.         IMPLICIT NONE
    1796. 

  1796. ! <DESCRIPTION>
    1797. 

  1797. ! This convenience function returns the current time for domain grid.  
    1798. 

  1798. !
    1799. 

  1799. ! </DESCRIPTION>
    1800. 

  1800.         TYPE(domain), INTENT(IN) :: grid
    1801. 

  1801.         ! result
    1802. 

  1802.         TYPE(WRFU_Time) :: current_time
    1803. 

  1803.         ! locals
    1804. 

  1804.         INTEGER :: rc
    1805. 

  1805.         CALL WRFU_ClockGet( grid%domain_clock, CurrTime=current_time, &
    1806. 

  1806.                             rc=rc )
    1807. 

  1807.         IF ( rc /= WRFU_SUCCESS ) THEN
    1808. 

  1808.           CALL wrf_error_fatal ( &
    1809. 

  1809.             'domain_get_current_time:  WRFU_ClockGet failed' )
    1810. 

  1810.         ENDIF
    1811. 

  1811.       END FUNCTION domain_get_current_time
    1812. 

  1812. 

  1813. 

  1814.       FUNCTION domain_get_start_time ( grid ) RESULT ( start_time ) 
    1815. 

  1815.         IMPLICIT NONE
    1816. 

  1816. ! <DESCRIPTION>
    1817. 

  1817. ! This convenience function returns the start time for domain grid.  
    1818. 

  1818. !
    1819. 

  1819. ! </DESCRIPTION>
    1820. 

  1820.         TYPE(domain), INTENT(IN) :: grid
    1821. 

  1821.         ! result
    1822. 

  1822.         TYPE(WRFU_Time) :: start_time
    1823. 

  1823.         ! locals
    1824. 

  1824.         INTEGER :: rc
    1825. 

  1825.         CALL WRFU_ClockGet( grid%domain_clock, StartTime=start_time, &
    1826. 

  1826.                             rc=rc )
    1827. 

  1827.         IF ( rc /= WRFU_SUCCESS ) THEN
    1828. 

  1828.           CALL wrf_error_fatal ( &
    1829. 

  1829.             'domain_get_start_time:  WRFU_ClockGet failed' )
    1830. 

  1830.         ENDIF
    1831. 

  1831.       END FUNCTION domain_get_start_time
    1832. 

  1832. 

  1833. 

  1834.       FUNCTION domain_get_stop_time ( grid ) RESULT ( stop_time ) 
    1835. 

  1835.         IMPLICIT NONE
    1836. 

  1836. ! <DESCRIPTION>
    1837. 

  1837. ! This convenience function returns the stop time for domain grid.  
    1838. 

  1838. !
    1839. 

  1839. ! </DESCRIPTION>
    1840. 

  1840.         TYPE(domain), INTENT(IN) :: grid
    1841. 

  1841.         ! result
    1842. 

  1842.         TYPE(WRFU_Time) :: stop_time
    1843. 

  1843.         ! locals
    1844. 

  1844.         INTEGER :: rc
    1845. 

  1845.         CALL WRFU_ClockGet( grid%domain_clock, StopTime=stop_time, &
    1846. 

  1846.                             rc=rc )
    1847. 

  1847.         IF ( rc /= WRFU_SUCCESS ) THEN
    1848. 

  1848.           CALL wrf_error_fatal ( &
    1849. 

  1849.             'domain_get_stop_time:  WRFU_ClockGet failed' )
    1850. 

  1850.         ENDIF
    1851. 

  1851.       END FUNCTION domain_get_stop_time
    1852. 

  1852. 

  1853. 

  1854.       FUNCTION domain_get_time_step ( grid ) RESULT ( time_step ) 
    1855. 

  1855.         IMPLICIT NONE
    1856. 

  1856. ! <DESCRIPTION>
    1857. 

  1857. ! This convenience function returns the time step for domain grid.  
    1858. 

  1858. !
    1859. 

  1859. ! </DESCRIPTION>
    1860. 

  1860.         TYPE(domain), INTENT(IN) :: grid
    1861. 

  1861.         ! result
    1862. 

  1862.         TYPE(WRFU_TimeInterval) :: time_step
    1863. 

  1863.         ! locals
    1864. 

  1864.         INTEGER :: rc
    1865. 

  1865.         CALL WRFU_ClockGet( grid%domain_clock, timeStep=time_step, &
    1866. 

  1866.                             rc=rc )
    1867. 

  1867.         IF ( rc /= WRFU_SUCCESS ) THEN
    1868. 

  1868.           CALL wrf_error_fatal ( &
    1869. 

  1869.             'domain_get_time_step:  WRFU_ClockGet failed' )
    1870. 

  1870.         ENDIF
    1871. 

  1871.       END FUNCTION domain_get_time_step
    1872. 

  1872. 

  1873. 

  1874.       FUNCTION domain_get_advanceCount ( grid ) RESULT ( advanceCount ) 
    1875. 

  1875.         IMPLICIT NONE
    1876. 

  1876. ! <DESCRIPTION>
    1877. 

  1877. ! This convenience function returns the time step for domain grid.  
    1878. 

  1878. ! Also converts from INTEGER(WRFU_KIND_I8) to INTEGER.  
    1879. 

  1879. !
    1880. 

  1880. ! </DESCRIPTION>
    1881. 

  1881.         TYPE(domain), INTENT(IN) :: grid
    1882. 

  1882.         ! result
    1883. 

  1883.         INTEGER :: advanceCount
    1884. 

  1884.         ! locals
    1885. 

  1885.         INTEGER(WRFU_KIND_I8) :: advanceCountLcl
    1886. 

  1886.         INTEGER :: rc
    1887. 

  1887.         CALL WRFU_ClockGet( grid%domain_clock, &
    1888. 

  1888.                             advanceCount=advanceCountLcl, &
    1889. 

  1889.                             rc=rc )
    1890. 

  1890.         IF ( rc /= WRFU_SUCCESS ) THEN
    1891. 

  1891.           CALL wrf_error_fatal ( &
    1892. 

  1892.             'domain_get_advanceCount:  WRFU_ClockGet failed' )
    1893. 

  1893.         ENDIF
    1894. 

  1894.         advanceCount = advanceCountLcl
    1895. 

  1895.       END FUNCTION domain_get_advanceCount
    1896. 

  1896. 

  1897. 

  1898.       SUBROUTINE domain_alarms_destroy ( grid )
    1899. 

  1899.         IMPLICIT NONE
    1900. 

  1900. ! <DESCRIPTION>
    1901. 

  1901. ! This convenience routine destroys and deallocates all alarms associated 
    1902. 

  1902. ! with grid.  
    1903. 

  1903. !
    1904. 

  1904. ! </DESCRIPTION>
    1905. 

  1905.         TYPE(domain), INTENT(INOUT) :: grid
    1906. 

  1906.         !  Local data.
    1907. 

  1907.         INTEGER                     :: alarmid
    1908. 

  1908. 

  1909.         IF ( ASSOCIATED( grid%alarms ) .AND. &
    1910. 

  1910.              ASSOCIATED( grid%alarms_created ) ) THEN
    1911. 

  1911.           DO alarmid = 1, MAX_WRF_ALARMS
    1912. 

  1912.             IF ( grid%alarms_created( alarmid ) ) THEN
    1913. 

  1913.               CALL WRFU_AlarmDestroy( grid%alarms( alarmid ) )
    1914. 

  1914.               grid%alarms_created( alarmid ) = .FALSE.
    1915. 

  1915.             ENDIF
    1916. 

  1916.           ENDDO
    1917. 

  1917.           DEALLOCATE( grid%alarms )
    1918. 

  1918.           NULLIFY( grid%alarms )
    1919. 

  1919.           DEALLOCATE( grid%alarms_created )
    1920. 

  1920.           NULLIFY( grid%alarms_created )
    1921. 

  1921.         ENDIF
    1922. 

  1922.       END SUBROUTINE domain_alarms_destroy
    1923. 

  1923. 

  1924. 

  1925.       SUBROUTINE domain_clock_destroy ( grid )
    1926. 

  1926.         IMPLICIT NONE
    1927. 

  1927. ! <DESCRIPTION>
    1928. 

  1928. ! This convenience routine destroys and deallocates the domain clock.  
    1929. 

  1929. !
    1930. 

  1930. ! </DESCRIPTION>
    1931. 

  1931.         TYPE(domain), INTENT(INOUT) :: grid
    1932. 

  1932.         IF ( ASSOCIATED( grid%domain_clock ) ) THEN
    1933. 

  1933.           IF ( grid%domain_clock_created ) THEN
    1934. 

  1934.             CALL WRFU_ClockDestroy( grid%domain_clock )
    1935. 

  1935.             grid%domain_clock_created = .FALSE.
    1936. 

  1936.           ENDIF
    1937. 

  1937.           DEALLOCATE( grid%domain_clock )
    1938. 

  1938.           NULLIFY( grid%domain_clock )
    1939. 

  1939.         ENDIF
    1940. 

  1940.       END SUBROUTINE domain_clock_destroy
    1941. 

  1941. 

  1942. 

  1943.       FUNCTION domain_last_time_step ( grid ) RESULT ( LAST_TIME ) 
    1944. 

  1944.         IMPLICIT NONE
    1945. 

  1945. ! <DESCRIPTION>
    1946. 

  1946. ! This convenience function returns .TRUE. if this is the last time 
    1947. 

  1947. ! step for domain grid.  Thanks to Tom Black.  
    1948. 

  1948. !
    1949. 

  1949. ! </DESCRIPTION>
    1950. 

  1950.         TYPE(domain), INTENT(IN) :: grid
    1951. 

  1951.         ! result
    1952. 

  1952.         LOGICAL :: LAST_TIME
    1953. 

  1953.         LAST_TIME =   domain_get_stop_time( grid ) .EQ. &
    1954. 

  1954.                     ( domain_get_current_time( grid ) + &
    1955. 

  1955.                       domain_get_time_step( grid ) )
    1956. 

  1956.       END FUNCTION domain_last_time_step
    1957. 

  1957. 

  1958. 

  1959. 

  1960.       FUNCTION domain_clockisstoptime ( grid ) RESULT ( is_stop_time ) 
    1961. 

  1961.         IMPLICIT NONE
    1962. 

  1962. ! <DESCRIPTION>
    1963. 

  1963. ! This convenience function returns .TRUE. iff grid%clock has reached its 
    1964. 

  1964. ! stop time.  
    1965. 

  1965. !
    1966. 

  1966. ! </DESCRIPTION>
    1967. 

  1967.         TYPE(domain), INTENT(IN) :: grid
    1968. 

  1968.         ! result
    1969. 

  1969.         LOGICAL :: is_stop_time
    1970. 

  1970.         INTEGER :: rc
    1971. 

  1971.         is_stop_time = WRFU_ClockIsStopTime( grid%domain_clock , rc=rc )
    1972. 

  1972.         IF ( rc /= WRFU_SUCCESS ) THEN
    1973. 

  1973.           CALL wrf_error_fatal ( &
    1974. 

  1974.             'domain_clockisstoptime:  WRFU_ClockIsStopTime() failed' )
    1975. 

  1975.         ENDIF
    1976. 

  1976.       END FUNCTION domain_clockisstoptime
    1977. 

  1977. 

  1978. 

  1979. 

  1980.       FUNCTION domain_clockisstopsubtime ( grid ) RESULT ( is_stop_subtime ) 
    1981. 

  1981.         IMPLICIT NONE
    1982. 

  1982. ! <DESCRIPTION>
    1983. 

  1983. ! This convenience function returns .TRUE. iff grid%clock has reached its 
    1984. 

  1984. ! grid%stop_subtime.  
    1985. 

  1985. !
    1986. 

  1986. ! </DESCRIPTION>
    1987. 

  1987.         TYPE(domain), INTENT(IN) :: grid
    1988. 

  1988.         ! result
    1989. 

  1989.         LOGICAL :: is_stop_subtime
    1990. 

  1990.         INTEGER :: rc
    1991. 

  1991.         TYPE(WRFU_TimeInterval) :: timeStep
    1992. 

  1992.         TYPE(WRFU_Time) :: currentTime
    1993. 

  1993.         LOGICAL :: positive_timestep
    1994. 

  1994.         is_stop_subtime = .FALSE.
    1995. 

  1995.         CALL domain_clock_get( grid, time_step=timeStep, &
    1996. 

  1996.                                      current_time=currentTime )
    1997. 

  1997.         positive_timestep = ESMF_TimeIntervalIsPositive( timeStep )
    1998. 

  1998.         IF ( positive_timestep ) THEN
    1999. 

  1999. ! hack for bug in PGI 5.1-x
    2000. 

  2000. !        IF ( currentTime .GE. grid%stop_subtime ) THEN
    2001. 

  2001.           IF ( ESMF_TimeGE( currentTime, grid%stop_subtime ) ) THEN
    2002. 

  2002.             is_stop_subtime = .TRUE.
    2003. 

  2003.           ENDIF
    2004. 

  2004.         ELSE
    2005. 

  2005. ! hack for bug in PGI 5.1-x
    2006. 

  2006. !        IF ( currentTime .LE. grid%stop_subtime ) THEN
    2007. 

  2007.           IF ( ESMF_TimeLE( currentTime, grid%stop_subtime ) ) THEN
    2008. 

  2008.             is_stop_subtime = .TRUE.
    2009. 

  2009.           ENDIF
    2010. 

  2010.         ENDIF
    2011. 

  2011.       END FUNCTION domain_clockisstopsubtime
    2012. 

  2012. 

  2013. 

  2014. 

  2015. 

  2016.       FUNCTION domain_get_sim_start_time ( grid ) RESULT ( simulationStartTime ) 
    2017. 

  2017.         IMPLICIT NONE
    2018. 

  2018. ! <DESCRIPTION>
    2019. 

  2019. ! This convenience routine returns simulation start time for domain grid as 
    2020. 

  2020. ! a time instant.  
    2021. 

  2021. !
    2022. 

  2022. ! If this is not a restart run, the start_time of head_grid%clock is returned 
    2023. 

  2023. ! instead.  
    2024. 

  2024. !
    2025. 

  2025. ! Note that simulation start time remains constant through restarts while 
    2026. 

  2026. ! the start_time of head_grid%clock always refers to the start time of the 
    2027. 

  2027. ! current run (restart or otherwise).  
    2028. 

  2028. !
    2029. 

  2029. ! </DESCRIPTION>
    2030. 

  2030.         TYPE(domain), INTENT(IN) :: grid
    2031. 

  2031.         ! result
    2032. 

  2032.         TYPE(WRFU_Time) :: simulationStartTime
    2033. 

  2033.         ! Locals
    2034. 

  2034.         INTEGER :: rc
    2035. 

  2035.         INTEGER :: simulation_start_year,   simulation_start_month, &
    2036. 

  2036.                    simulation_start_day,    simulation_start_hour , &
    2037. 

  2037.                    simulation_start_minute, simulation_start_second
    2038. 

  2038.         CALL nl_get_simulation_start_year   ( 1, simulation_start_year   )
    2039. 

  2039.         CALL nl_get_simulation_start_month  ( 1, simulation_start_month  )
    2040. 

  2040.         CALL nl_get_simulation_start_day    ( 1, simulation_start_day    )
    2041. 

  2041.         CALL nl_get_simulation_start_hour   ( 1, simulation_start_hour   )
    2042. 

  2042.         CALL nl_get_simulation_start_minute ( 1, simulation_start_minute )
    2043. 

  2043.         CALL nl_get_simulation_start_second ( 1, simulation_start_second )
    2044. 

  2044.         CALL WRFU_TimeSet( simulationStartTime,       &
    2045. 

  2045.                            YY=simulation_start_year,  &
    2046. 

  2046.                            MM=simulation_start_month, &
    2047. 

  2047.                            DD=simulation_start_day,   &
    2048. 

  2048.                            H=simulation_start_hour,   &
    2049. 

  2049.                            M=simulation_start_minute, &
    2050. 

  2050.                            S=simulation_start_second, &
    2051. 

  2051.                            rc=rc )
    2052. 

  2052.         IF ( rc /= WRFU_SUCCESS ) THEN
    2053. 

  2053.           CALL nl_get_start_year   ( 1, simulation_start_year   )
    2054. 

  2054.           CALL nl_get_start_month  ( 1, simulation_start_month  )
    2055. 

  2055.           CALL nl_get_start_day    ( 1, simulation_start_day    )
    2056. 

  2056.           CALL nl_get_start_hour   ( 1, simulation_start_hour   )
    2057. 

  2057.           CALL nl_get_start_minute ( 1, simulation_start_minute )
    2058. 

  2058.           CALL nl_get_start_second ( 1, simulation_start_second )
    2059. 

  2059.           CALL wrf_debug( 150, "WARNING:  domain_get_sim_start_time using head_grid start time from namelist" )
    2060. 

  2060.           CALL WRFU_TimeSet( simulationStartTime,       &
    2061. 

  2061.                              YY=simulation_start_year,  &
    2062. 

  2062.                              MM=simulation_start_month, &
    2063. 

  2063.                              DD=simulation_start_day,   &
    2064. 

  2064.                              H=simulation_start_hour,   &
    2065. 

  2065.                              M=simulation_start_minute, &
    2066. 

  2066.                              S=simulation_start_second, &
    2067. 

  2067.                              rc=rc )
    2068. 

  2068.         ENDIF
    2069. 

  2069.         RETURN
    2070. 

  2070.       END FUNCTION domain_get_sim_start_time
    2071. 

  2071. 

  2072.       FUNCTION domain_get_time_since_sim_start ( grid ) RESULT ( time_since_sim_start ) 
    2073. 

  2073.         IMPLICIT NONE
    2074. 

  2074. ! <DESCRIPTION>
    2075. 

  2075. ! This convenience function returns the time elapsed since start of 
    2076. 

  2076. ! simulation for domain grid.  
    2077. 

  2077. !
    2078. 

  2078. ! Note that simulation start time remains constant through restarts while 
    2079. 

  2079. ! the start_time of grid%clock always refers to the start time of the 
    2080. 

  2080. ! current run (restart or otherwise).  
    2081. 

  2081. !
    2082. 

  2082. ! </DESCRIPTION>
    2083. 

  2083.         TYPE(domain), INTENT(IN) :: grid
    2084. 

  2084.         ! result
    2085. 

  2085.         TYPE(WRFU_TimeInterval) :: time_since_sim_start
    2086. 

  2086.         ! locals
    2087. 

  2087.         TYPE(WRFU_Time) :: lcl_currtime, lcl_simstarttime
    2088. 

  2088.         lcl_simstarttime = domain_get_sim_start_time( grid )
    2089. 

  2089.         lcl_currtime = domain_get_current_time ( grid )
    2090. 

  2090.         time_since_sim_start = lcl_currtime - lcl_simstarttime
    2091. 

  2091.       END FUNCTION domain_get_time_since_sim_start
    2092. 

  2092. 

  2093. 

  2094. 

  2095. 

  2096.       SUBROUTINE domain_clock_get( grid, current_time,                &
    2097. 

  2097.                                          current_timestr,             &
    2098. 

  2098.                                          current_timestr_frac,        &
    2099. 

  2099.                                          start_time, start_timestr,   &
    2100. 

  2100.                                          stop_time, stop_timestr,     &
    2101. 

  2101.                                          time_step, time_stepstr,     &
    2102. 

  2102.                                          time_stepstr_frac,           &
    2103. 

  2103.                                          advanceCount,                &
    2104. 

  2104.                                          currentDayOfYearReal,        &
    2105. 

  2105.                                          minutesSinceSimulationStart, &
    2106. 

  2106.                                          timeSinceSimulationStart,    &
    2107. 

  2107.                                          simulationStartTime,         &
    2108. 

  2108.                                          simulationStartTimeStr )
    2109. 

  2109.         IMPLICIT NONE
    2110. 

  2110.         TYPE(domain),            INTENT(IN)              :: grid
    2111. 

  2111.         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: current_time
    2112. 

  2112.         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: current_timestr
    2113. 

  2113.         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: current_timestr_frac
    2114. 

  2114.         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: start_time
    2115. 

  2115.         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: start_timestr
    2116. 

  2116.         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: stop_time
    2117. 

  2117.         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: stop_timestr
    2118. 

  2118.         TYPE(WRFU_TimeInterval), INTENT(  OUT), OPTIONAL :: time_step
    2119. 

  2119.         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: time_stepstr
    2120. 

  2120.         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: time_stepstr_frac
    2121. 

  2121.         INTEGER,                 INTENT(  OUT), OPTIONAL :: advanceCount
    2122. 

  2122.         ! currentDayOfYearReal = 0.0 at 0Z on 1 January, 0.5 at 12Z on 
    2123. 

  2123.         ! 1 January, etc.
    2124. 

  2124.         REAL,                    INTENT(  OUT), OPTIONAL :: currentDayOfYearReal
    2125. 

  2125.         ! Time at which simulation started.  If this is not a restart run, 
    2126. 

  2126.         ! start_time is returned instead.  
    2127. 

  2127.         TYPE(WRFU_Time),         INTENT(  OUT), OPTIONAL :: simulationStartTime
    2128. 

  2128.         CHARACTER (LEN=*),       INTENT(  OUT), OPTIONAL :: simulationStartTimeStr
    2129. 

  2129.         ! time interval since start of simulation, includes effects of 
    2130. 

  2130.         ! restarting even when restart uses a different timestep
    2131. 

  2131.         TYPE(WRFU_TimeInterval), INTENT(  OUT), OPTIONAL :: timeSinceSimulationStart
    2132. 

  2132.         ! minutes since simulation start date
    2133. 

  2133.         REAL,                    INTENT(  OUT), OPTIONAL :: minutesSinceSimulationStart
    2134. 

  2134. ! <DESCRIPTION>
    2135. 

  2135. ! This convenience routine returns clock information for domain grid in 
    2136. 

  2136. ! various forms.  The caller is responsible for ensuring that character 
    2137. 

  2137. ! string actual arguments are big enough.  
    2138. 

  2138. !
    2139. 

  2139. ! </DESCRIPTION>
    2140. 

  2140.         ! Locals
    2141. 

  2141.         TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime, lcl_starttime
    2142. 

  2142.         TYPE(WRFU_Time) :: lcl_simulationStartTime
    2143. 

  2143.         TYPE(WRFU_TimeInterval) :: lcl_time_step, lcl_timeSinceSimulationStart
    2144. 

  2144.         INTEGER :: days, seconds, Sn, Sd, rc
    2145. 

  2145.         CHARACTER (LEN=256) :: tmp_str
    2146. 

  2146.         CHARACTER (LEN=256) :: frac_str
    2147. 

  2147.         REAL(WRFU_KIND_R8) :: currentDayOfYearR8
    2148. 

  2148.         IF ( PRESENT( start_time ) ) THEN
    2149. 

  2149.           start_time = domain_get_start_time ( grid )
    2150. 

  2150.         ENDIF
    2151. 

  2151.         IF ( PRESENT( start_timestr ) ) THEN
    2152. 

  2152.           lcl_starttime = domain_get_start_time ( grid )
    2153. 

  2153.           CALL wrf_timetoa ( lcl_starttime, start_timestr )
    2154. 

  2154.         ENDIF
    2155. 

  2155.         IF ( PRESENT( time_step ) ) THEN
    2156. 

  2156.           time_step = domain_get_time_step ( grid )
    2157. 

  2157.         ENDIF
    2158. 

  2158.         IF ( PRESENT( time_stepstr ) ) THEN
    2159. 

  2159.           lcl_time_step = domain_get_time_step ( grid )
    2160. 

  2160.           CALL WRFU_TimeIntervalGet( lcl_time_step, &
    2161. 

  2161.                                      timeString=time_stepstr, rc=rc )
    2162. 

  2162.           IF ( rc /= WRFU_SUCCESS ) THEN
    2163. 

  2163.             CALL wrf_error_fatal ( &
    2164. 

  2164.               'domain_clock_get:  WRFU_TimeIntervalGet() failed' )
    2165. 

  2165.           ENDIF
    2166. 

  2166.         ENDIF
    2167. 

  2167.         IF ( PRESENT( time_stepstr_frac ) ) THEN
    2168. 

  2168.           lcl_time_step = domain_get_time_step ( grid )
    2169. 

  2169.           CALL WRFU_TimeIntervalGet( lcl_time_step, timeString=tmp_str, &
    2170. 

  2170.                                      Sn=Sn, Sd=Sd, rc=rc )
    2171. 

  2171.           IF ( rc /= WRFU_SUCCESS ) THEN
    2172. 

  2172.             CALL wrf_error_fatal ( &
    2173. 

  2173.               'domain_clock_get:  WRFU_TimeIntervalGet() failed' )
    2174. 

  2174.           ENDIF
    2175. 

  2175.           CALL fraction_to_string( Sn, Sd, frac_str )
    2176. 

  2176.           time_stepstr_frac = TRIM(tmp_str)//TRIM(frac_str)
    2177. 

  2177.         ENDIF
    2178. 

  2178.         IF ( PRESENT( advanceCount ) ) THEN
    2179. 

  2179.           advanceCount = domain_get_advanceCount ( grid )
    2180. 

  2180.         ENDIF
    2181. 

  2181.         ! This duplication avoids assignment of time-manager objects 
    2182. 

  2182.         ! which works now in ESMF 2.2.0 but may not work in the future 
    2183. 

  2183.         ! if these objects become "deep".  We have already been bitten 
    2184. 

  2184.         ! by this when the clock objects were changed from "shallow" to 
    2185. 

  2185.         ! "deep".  Once again, adherence to orthodox canonical form by 
    2186. 

  2186.         ! ESMF would avoid all this crap.  
    2187. 

  2187.         IF ( PRESENT( current_time ) ) THEN
    2188. 

  2188.           current_time = domain_get_current_time ( grid )
    2189. 

  2189.         ENDIF
    2190. 

  2190.         IF ( PRESENT( current_timestr ) ) THEN
    2191. 

  2191.           lcl_currtime = domain_get_current_time ( grid )
    2192. 

  2192.           CALL wrf_timetoa ( lcl_currtime, current_timestr )
    2193. 

  2193.         ENDIF
    2194. 

  2194.         ! current time string including fractional part, if present
    2195. 

  2195.         IF ( PRESENT( current_timestr_frac ) ) THEN
    2196. 

  2196.           lcl_currtime = domain_get_current_time ( grid )
    2197. 

  2197.           CALL wrf_timetoa ( lcl_currtime, tmp_str )
    2198. 

  2198.           CALL WRFU_TimeGet( lcl_currtime, Sn=Sn, Sd=Sd, rc=rc )
    2199. 

  2199.           IF ( rc /= WRFU_SUCCESS ) THEN
    2200. 

  2200.             CALL wrf_error_fatal ( &
    2201. 

  2201.               'domain_clock_get:  WRFU_TimeGet() failed' )
    2202. 

  2202.           ENDIF
    2203. 

  2203.           CALL fraction_to_string( Sn, Sd, frac_str )
    2204. 

  2204.           current_timestr_frac = TRIM(tmp_str)//TRIM(frac_str)
    2205. 

  2205.         ENDIF
    2206. 

  2206.         IF ( PRESENT( stop_time ) ) THEN
    2207. 

  2207.           stop_time = domain_get_stop_time ( grid )
    2208. 

  2208.         ENDIF
    2209. 

  2209.         IF ( PRESENT( stop_timestr ) ) THEN
    2210. 

  2210.           lcl_stoptime = domain_get_stop_time ( grid )
    2211. 

  2211.           CALL wrf_timetoa ( lcl_stoptime, stop_timestr )
    2212. 

  2212.         ENDIF
    2213. 

  2213.         IF ( PRESENT( currentDayOfYearReal ) ) THEN
    2214. 

  2214.           lcl_currtime = domain_get_current_time ( grid )
    2215. 

  2215.           CALL WRFU_TimeGet( lcl_currtime, dayOfYear_r8=currentDayOfYearR8, &
    2216. 

  2216.                              rc=rc )
    2217. 

  2217.           IF ( rc /= WRFU_SUCCESS ) THEN
    2218. 

  2218.             CALL wrf_error_fatal ( &
    2219. 

  2219.                    'domain_clock_get:  WRFU_TimeGet(dayOfYear_r8) failed' )
    2220. 

  2220.           ENDIF
    2221. 

  2221.           currentDayOfYearReal = REAL( currentDayOfYearR8 ) - 1.0
    2222. 

  2222.         ENDIF
    2223. 

  2223.         IF ( PRESENT( simulationStartTime ) ) THEN
    2224. 

  2224.           simulationStartTime = domain_get_sim_start_time( grid )
    2225. 

  2225.         ENDIF
    2226. 

  2226.         IF ( PRESENT( simulationStartTimeStr ) ) THEN
    2227. 

  2227.           lcl_simulationStartTime = domain_get_sim_start_time( grid )
    2228. 

  2228.           CALL wrf_timetoa ( lcl_simulationStartTime, simulationStartTimeStr )
    2229. 

  2229.         ENDIF
    2230. 

  2230.         IF ( PRESENT( timeSinceSimulationStart ) ) THEN
    2231. 

  2231.           timeSinceSimulationStart = domain_get_time_since_sim_start( grid )
    2232. 

  2232.         ENDIF
    2233. 

  2233.         IF ( PRESENT( minutesSinceSimulationStart ) ) THEN
    2234. 

  2234.           lcl_timeSinceSimulationStart = domain_get_time_since_sim_start( grid )
    2235. 

  2235.           CALL WRFU_TimeIntervalGet( lcl_timeSinceSimulationStart, &
    2236. 

  2236.                                      D=days, S=seconds, Sn=Sn, Sd=Sd, rc=rc )
    2237. 

  2237.           IF ( rc /= WRFU_SUCCESS ) THEN
    2238. 

  2238.             CALL wrf_error_fatal ( &
    2239. 

  2239.                    'domain_clock_get:  WRFU_TimeIntervalGet() failed' )
    2240. 

  2240.           ENDIF
    2241. 

  2241.           ! get rid of hard-coded constants
    2242. 

  2242.           minutesSinceSimulationStart = ( REAL( days ) * 24. * 60. ) + &
    2243. 

  2243.                                         ( REAL( seconds ) / 60. )
    2244. 

  2244.           IF ( Sd /= 0 ) THEN
    2245. 

  2245.             minutesSinceSimulationStart = minutesSinceSimulationStart + &
    2246. 

  2246.                                           ( ( REAL( Sn ) / REAL( Sd ) ) / 60. )
    2247. 

  2247.           ENDIF
    2248. 

  2248.         ENDIF
    2249. 

  2249.         RETURN
    2250. 

  2250.       END SUBROUTINE domain_clock_get
    2251. 

  2251. 

  2252.       FUNCTION domain_clockisstarttime ( grid ) RESULT ( is_start_time ) 
    2253. 

  2253.         IMPLICIT NONE
    2254. 

  2254. ! <DESCRIPTION>
    2255. 

  2255. ! This convenience function returns .TRUE. iff grid%clock is at its 
    2256. 

  2256. ! start time.  
    2257. 

  2257. !
    2258. 

  2258. ! </DESCRIPTION>
    2259. 

  2259.         TYPE(domain), INTENT(IN) :: grid
    2260. 

  2260.         ! result
    2261. 

  2261.         LOGICAL :: is_start_time
    2262. 

  2262.         TYPE(WRFU_Time) :: start_time, current_time
    2263. 

  2263.         CALL domain_clock_get( grid, current_time=current_time, &
    2264. 

  2264.                                      start_time=start_time )
    2265. 

  2265.         is_start_time = ( current_time == start_time )
    2266. 

  2266.       END FUNCTION domain_clockisstarttime
    2267. 

  2267. 

  2268.       FUNCTION domain_clockissimstarttime ( grid ) RESULT ( is_sim_start_time ) 
    2269. 

  2269.         IMPLICIT NONE
    2270. 

  2270. ! <DESCRIPTION>
    2271. 

  2271. ! This convenience function returns .TRUE. iff grid%clock is at the 
    2272. 

  2272. ! simulation start time.  (It returns .FALSE. during a restart run.)  
    2273. 

  2273. !
    2274. 

  2274. ! </DESCRIPTION>
    2275. 

  2275.         TYPE(domain), INTENT(IN) :: grid
    2276. 

  2276.         ! result
    2277. 

  2277.         LOGICAL :: is_sim_start_time
    2278. 

  2278.         TYPE(WRFU_Time) :: simulationStartTime, current_time
    2279. 

  2279.         CALL domain_clock_get( grid, current_time=current_time, &
    2280. 

  2280.                                      simulationStartTime=simulationStartTime )
    2281. 

  2281.         is_sim_start_time = ( current_time == simulationStartTime )
    2282. 

  2282.       END FUNCTION domain_clockissimstarttime
    2283. 

  2283. 

  2284. 

  2285. 

  2286. 

  2287.       SUBROUTINE domain_clock_create( grid, StartTime, &
    2288. 

  2288.                                             StopTime,  &
    2289. 

  2289.                                             TimeStep )
    2290. 

  2290.         IMPLICIT NONE
    2291. 

  2291.         TYPE(domain),            INTENT(INOUT) :: grid
    2292. 

  2292.         TYPE(WRFU_Time),         INTENT(IN   ) :: StartTime
    2293. 

  2293.         TYPE(WRFU_Time),         INTENT(IN   ) :: StopTime
    2294. 

  2294.         TYPE(WRFU_TimeInterval), INTENT(IN   ) :: TimeStep
    2295. 

  2295. ! <DESCRIPTION>
    2296. 

  2296. ! This convenience routine creates the domain_clock for domain grid and 
    2297. 

  2297. ! sets associated flags.  
    2298. 

  2298. !
    2299. 

  2299. ! </DESCRIPTION>
    2300. 

  2300.         ! Locals
    2301. 

  2301.         INTEGER :: rc
    2302. 

  2302.         grid%domain_clock = WRFU_ClockCreate( TimeStep= TimeStep,  &
    2303. 

  2303.                                               StartTime=StartTime, &
    2304. 

  2304.                                               StopTime= StopTime,  &
    2305. 

  2305.                                               rc=rc )
    2306. 

  2306.         IF ( rc /= WRFU_SUCCESS ) THEN
    2307. 

  2307.           CALL wrf_error_fatal ( &
    2308. 

  2308.             'domain_clock_create:  WRFU_ClockCreate() failed' )
    2309. 

  2309.         ENDIF
    2310. 

  2310.         grid%domain_clock_created = .TRUE.
    2311. 

  2311.         RETURN
    2312. 

  2312.       END SUBROUTINE domain_clock_create
    2313. 

  2313. 

  2314. 

  2315. 

  2316.       SUBROUTINE domain_alarm_create( grid, alarm_id, interval, &
    2317. 

  2317.                                             begin_time, end_time )
    2318. 

  2318.         USE module_utility
    2319. 

  2319.         IMPLICIT NONE
    2320. 

  2320.         TYPE(domain), POINTER :: grid
    2321. 

  2321.         INTEGER, INTENT(IN) :: alarm_id
    2322. 

  2322.         TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: interval
    2323. 

  2323.         TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: begin_time
    2324. 

  2324.         TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: end_time
    2325. 

  2325. ! <DESCRIPTION>
    2326. 

  2326. ! This convenience routine creates alarm alarm_id for domain grid and 
    2327. 

  2327. ! sets associated flags.  
    2328. 

  2328. !
    2329. 

  2329. ! </DESCRIPTION>
    2330. 

  2330.         ! Locals
    2331. 

  2331.         INTEGER :: rc
    2332. 

  2332. !$$$ TBH:  Ideally, this could be simplified by passing all optional actual 
    2333. 

  2333. !$$$ TBH:  args into AlarmCreate.  However, since operations are performed on 
    2334. 

  2334. !$$$ TBH:  the actual args in-place in the calls, they must be present for the 
    2335. 

  2335. !$$$ TBH:  operations themselves to be defined.  Grrr...  
    2336. 

  2336.         LOGICAL :: interval_only, all_args, no_args
    2337. 

  2337.         TYPE(WRFU_Time) :: startTime
    2338. 

  2338.         interval_only = .FALSE.
    2339. 

  2339.         all_args = .FALSE.
    2340. 

  2340.         no_args = .FALSE.
    2341. 

  2341.         IF ( ( .NOT. PRESENT( begin_time ) ) .AND. &
    2342. 

  2342.              ( .NOT. PRESENT( end_time   ) ) .AND. &
    2343. 

  2343.              (       PRESENT( interval   ) ) ) THEN
    2344. 

  2344.            interval_only = .TRUE.
    2345. 

  2345.         ELSE IF ( ( .NOT. PRESENT( begin_time ) ) .AND. &
    2346. 

  2346.                   ( .NOT. PRESENT( end_time   ) ) .AND. &
    2347. 

  2347.                   ( .NOT. PRESENT( interval   ) ) ) THEN
    2348. 

  2348.            no_args = .TRUE.
    2349. 

  2349.         ELSE IF ( (       PRESENT( begin_time ) ) .AND. &
    2350. 

  2350.                   (       PRESENT( end_time   ) ) .AND. &
    2351. 

  2351.                   (       PRESENT( interval   ) ) ) THEN
    2352. 

  2352.            all_args = .TRUE.
    2353. 

  2353.         ELSE
    2354. 

  2354.            CALL wrf_error_fatal ( &
    2355. 

  2355.              'ERROR in domain_alarm_create:  bad argument list' )
    2356. 

  2356.         ENDIF
    2357. 

  2357.         CALL domain_clock_get( grid, start_time=startTime )
    2358. 

  2358.         IF ( interval_only ) THEN
    2359. 

  2359.            grid%io_intervals( alarm_id ) = interval
    2360. 

  2360.            grid%alarms( alarm_id ) = &
    2361. 

  2361.              WRFU_AlarmCreate( clock=grid%domain_clock, &
    2362. 

  2362.                                RingInterval=interval,   &
    2363. 

  2363.                                rc=rc )
    2364. 

  2364.         ELSE IF ( no_args ) THEN
    2365. 

  2365.            grid%alarms( alarm_id ) = &
    2366. 

  2366.              WRFU_AlarmCreate( clock=grid%domain_clock, &
    2367. 

  2367.                                RingTime=startTime,      &
    2368. 

  2368.                                rc=rc )
    2369. 

  2369.         ELSE IF ( all_args ) THEN
    2370. 

  2370.            grid%io_intervals( alarm_id ) = interval
    2371. 

  2371.            grid%alarms( alarm_id ) = &
    2372. 

  2372.              WRFU_AlarmCreate( clock=grid%domain_clock,         &
    2373. 

  2373.                                RingTime=startTime + begin_time, &
    2374. 

  2374.                                RingInterval=interval,           &
    2375. 

  2375.                                StopTime=startTime + end_time,   &
    2376. 

  2376.                                rc=rc )
    2377. 

  2377.         ENDIF
    2378. 

  2378.         IF ( rc /= WRFU_SUCCESS ) THEN
    2379. 

  2379.           CALL wrf_error_fatal ( &
    2380. 

  2380.             'domain_alarm_create:  WRFU_AlarmCreate() failed' )
    2381. 

  2381.         ENDIF
    2382. 

  2382.         CALL WRFU_AlarmRingerOff( grid%alarms( alarm_id ) , rc=rc )
    2383. 

  2383.         IF ( rc /= WRFU_SUCCESS ) THEN
    2384. 

  2384.           CALL wrf_error_fatal ( &
    2385. 

  2385.             'domain_alarm_create:  WRFU_AlarmRingerOff() failed' )
    2386. 

  2386.         ENDIF
    2387. 

  2387.         grid%alarms_created( alarm_id ) = .TRUE.
    2388. 

  2388.       END SUBROUTINE domain_alarm_create
    2389. 

  2389. 

  2390. 

  2391. 

  2392.       SUBROUTINE domain_clock_set( grid, current_timestr, &
    2393. 

  2393.                                          stop_timestr,    &
    2394. 

  2394.                                          time_step_seconds )
    2395. 

  2395.         IMPLICIT NONE
    2396. 

  2396.         TYPE(domain),      INTENT(INOUT)           :: grid
    2397. 

  2397.         CHARACTER (LEN=*), INTENT(IN   ), OPTIONAL :: current_timestr
    2398. 

  2398.         CHARACTER (LEN=*), INTENT(IN   ), OPTIONAL :: stop_timestr
    2399. 

  2399.         INTEGER,           INTENT(IN   ), OPTIONAL :: time_step_seconds
    2400. 

  2400. ! <DESCRIPTION>
    2401. 

  2401. ! This convenience routine sets clock information for domain grid.  
    2402. 

  2402. ! The caller is responsible for ensuring that character string actual 
    2403. 

  2403. ! arguments are big enough.  
    2404. 

  2404. !
    2405. 

  2405. ! </DESCRIPTION>
    2406. 

  2406.         ! Locals
    2407. 

  2407.         TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime
    2408. 

  2408.         TYPE(WRFU_TimeInterval) :: tmpTimeInterval
    2409. 

  2409.         INTEGER :: rc
    2410. 

  2410.         IF ( PRESENT( current_timestr ) ) THEN
    2411. 

  2411.           CALL wrf_atotime( current_timestr(1:19), lcl_currtime )
    2412. 

  2412.           CALL WRFU_ClockSet( grid%domain_clock, currTime=lcl_currtime, &
    2413. 

  2413.                               rc=rc )
    2414. 

  2414.           IF ( rc /= WRFU_SUCCESS ) THEN
    2415. 

  2415.             CALL wrf_error_fatal ( &
    2416. 

  2416.               'domain_clock_set:  WRFU_ClockSet(CurrTime) failed' )
    2417. 

  2417.           ENDIF
    2418. 

  2418.         ENDIF
    2419. 

  2419.         IF ( PRESENT( stop_timestr ) ) THEN
    2420. 

  2420.           CALL wrf_atotime( stop_timestr(1:19), lcl_stoptime )
    2421. 

  2421.           CALL WRFU_ClockSet( grid%domain_clock, stopTime=lcl_stoptime, &
    2422. 

  2422.                               rc=rc )
    2423. 

  2423.           IF ( rc /= WRFU_SUCCESS ) THEN
    2424. 

  2424.             CALL wrf_error_fatal ( &
    2425. 

  2425.               'domain_clock_set:  WRFU_ClockSet(StopTime) failed' )
    2426. 

  2426.           ENDIF
    2427. 

  2427.         ENDIF
    2428. 

  2428.         IF ( PRESENT( time_step_seconds ) ) THEN
    2429. 

  2429.           CALL WRFU_TimeIntervalSet( tmpTimeInterval, &
    2430. 

  2430.                                      S=time_step_seconds, rc=rc )
    2431. 

  2431.           IF ( rc /= WRFU_SUCCESS ) THEN
    2432. 

  2432.             CALL wrf_error_fatal ( &
    2433. 

  2433.               'domain_clock_set:  WRFU_TimeIntervalSet failed' )
    2434. 

  2434.           ENDIF
    2435. 

  2435.           CALL WRFU_ClockSet ( grid%domain_clock,        &
    2436. 

  2436.                                timeStep=tmpTimeInterval, &
    2437. 

  2437.                                rc=rc )
    2438. 

  2438.           IF ( rc /= WRFU_SUCCESS ) THEN
    2439. 

  2439.             CALL wrf_error_fatal ( &
    2440. 

  2440.               'domain_clock_set:  WRFU_ClockSet(TimeStep) failed' )
    2441. 

  2441.           ENDIF
    2442. 

  2442.         ENDIF
    2443. 

  2443.         RETURN
    2444. 

  2444.       END SUBROUTINE domain_clock_set
    2445. 

  2445. 

  2446. 

  2447.       ! Debug routine to print key clock information.  
    2448. 

  2448.       ! Printed lines include pre_str.  
    2449. 

  2449.       SUBROUTINE domain_clockprint ( level, grid, pre_str )
    2450. 

  2450.         IMPLICIT NONE
    2451. 

  2451.         INTEGER,           INTENT( IN) :: level
    2452. 

  2452.         TYPE(domain),      INTENT( IN) :: grid
    2453. 

  2453.         CHARACTER (LEN=*), INTENT( IN) :: pre_str
    2454. 

  2454.         CALL wrf_clockprint ( level, grid%domain_clock, pre_str )
    2455. 

  2455.         RETURN
    2456. 

  2456.       END SUBROUTINE domain_clockprint
    2457. 

  2457. 

  2458. 

  2459.       ! Advance the clock associated with grid.  
    2460. 

  2460.       ! Also updates several derived time quantities in grid state.  
    2461. 

  2461.       SUBROUTINE domain_clockadvance ( grid )
    2462. 

  2462.         IMPLICIT NONE
    2463. 

  2463.         TYPE(domain), INTENT(INOUT) :: grid
    2464. 

  2464.         INTEGER :: rc
    2465. 

  2465.         CALL domain_clockprint ( 250, grid, &
    2466. 

  2466.           'DEBUG domain_clockadvance():  before WRFU_ClockAdvance,' )
    2467. 

  2467.         CALL WRFU_ClockAdvance( grid%domain_clock, rc=rc )
    2468. 

  2468.         IF ( rc /= WRFU_SUCCESS ) THEN
    2469. 

  2469.           CALL wrf_error_fatal ( &
    2470. 

  2470.             'domain_clockadvance:  WRFU_ClockAdvance() failed' )
    2471. 

  2471.         ENDIF
    2472. 

  2472.         CALL domain_clockprint ( 250, grid, &
    2473. 

  2473.           'DEBUG domain_clockadvance():  after WRFU_ClockAdvance,' )
    2474. 

  2474.         ! Update derived time quantities in grid state.
    2475. 

  2475.         ! These are initialized in setup_timekeeping().
    2476. 

  2476.         CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime )
    2477. 

  2477.         CALL domain_clock_get( grid, currentDayOfYearReal=grid%julian )
    2478. 

  2478.         RETURN
    2479. 

  2479.       END SUBROUTINE domain_clockadvance
    2480. 

  2480. 

  2481. 

  2482. 

  2483.       ! Set grid%gmt, grid%julday, and grid%julyr from simulation-start-date.  
    2484. 

  2484.       ! Set start_of_simulation to TRUE iff current_time == simulation_start_time
    2485. 

  2485.       SUBROUTINE domain_setgmtetc ( grid, start_of_simulation )
    2486. 

  2486.         IMPLICIT NONE
    2487. 

  2487.         TYPE (domain), INTENT(INOUT) :: grid
    2488. 

  2488.         LOGICAL,       INTENT(  OUT) :: start_of_simulation
    2489. 

  2489.         ! locals
    2490. 

  2490.         CHARACTER (LEN=132)          :: message
    2491. 

  2491.         TYPE(WRFU_Time)              :: simStartTime
    2492. 

  2492.         INTEGER                      :: hr, mn, sec, ms, rc
    2493. 

  2493.         CALL domain_clockprint(150, grid, &
    2494. 

  2494.           'DEBUG domain_setgmtetc():  get simStartTime from clock,')
    2495. 

  2495.         CALL domain_clock_get( grid, simulationStartTime=simStartTime, &
    2496. 

  2496.                                      simulationStartTimeStr=message )
    2497. 

  2497.         CALL WRFU_TimeGet( simStartTime, YY=grid%julyr, dayOfYear=grid%julday, &
    2498. 

  2498.                            H=hr, M=mn, S=sec, MS=ms, rc=rc)
    2499. 

  2499.         IF ( rc /= WRFU_SUCCESS ) THEN
    2500. 

  2500.           CALL wrf_error_fatal ( &
    2501. 

  2501.             'domain_setgmtetc:  WRFU_TimeGet() failed' )
    2502. 

  2502.         ENDIF
    2503. 

  2503.         WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc():  simulation start time = [',TRIM( message ),']'
    2504. 

  2504.         CALL wrf_debug( 150, TRIM(wrf_err_message) )
    2505. 

  2505.         grid%gmt=hr+real(mn)/60.+real(sec)/3600.+real(ms)/(1000*3600)
    2506. 

  2506.         WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc():  julyr,hr,mn,sec,ms,julday = ', &
    2507. 

  2507.                                      grid%julyr,hr,mn,sec,ms,grid%julday
    2508. 

  2508.         CALL wrf_debug( 150, TRIM(wrf_err_message) )
    2509. 

  2509.         WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc():  gmt = ',grid%gmt
    2510. 

  2510.         CALL wrf_debug( 150, TRIM(wrf_err_message) )
    2511. 

  2511.         start_of_simulation = domain_ClockIsSimStartTime(grid)
    2512. 

  2512.         RETURN
    2513. 

  2513.       END SUBROUTINE domain_setgmtetc
    2514. 

  2514.      
    2515. 

  2515. 

  2516. 

  2517.       ! Set pointer to current grid.  
    2518. 

  2518.       ! To begin with, current grid is not set.  
    2519. 

  2519.       SUBROUTINE set_current_grid_ptr( grid_ptr )
    2520. 

  2520.         IMPLICIT NONE
    2521. 

  2521.         TYPE(domain), POINTER :: grid_ptr
    2522. 

  2522. !PRINT *,'DEBUG:  begin set_current_grid_ptr()'
    2523. 

  2523. !IF ( ASSOCIATED( grid_ptr ) ) THEN
    2524. 

  2524. !  PRINT *,'DEBUG:  set_current_grid_ptr():  current_grid is associated'
    2525. 

  2525. !ELSE
    2526. 

  2526. !  PRINT *,'DEBUG:  set_current_grid_ptr():  current_grid is NOT associated'
    2527. 

  2527. !ENDIF
    2528. 

  2528.         current_grid_set = .TRUE.
    2529. 

  2529.         current_grid => grid_ptr
    2530. 

  2530. !PRINT *,'DEBUG:  end set_current_grid_ptr()'
    2531. 

  2531.       END SUBROUTINE set_current_grid_ptr
    2532. 

  2532. 

  2533. !******************************************************************************
    2534. 

  2534. ! BEGIN TEST SECTION
    2535. 

  2535. !   Code in the test section is used to test domain methods.  
    2536. 

  2536. !   This code should probably be moved elsewhere, eventually.  
    2537. 

  2537. !******************************************************************************
    2538. 

  2538. 

  2539.       ! Private utility routines for domain_time_test.  
    2540. 

  2540.       SUBROUTINE domain_time_test_print ( pre_str, name_str, res_str )
    2541. 

  2541.         IMPLICIT NONE
    2542. 

  2542.         CHARACTER (LEN=*), INTENT(IN) :: pre_str
    2543. 

  2543.         CHARACTER (LEN=*), INTENT(IN) :: name_str
    2544. 

  2544.         CHARACTER (LEN=*), INTENT(IN) :: res_str
    2545. 

  2545.         CHARACTER (LEN=512) :: out_str
    2546. 

  2546.         WRITE (out_str,                                            &
    2547. 

  2547.           FMT="('DOMAIN_TIME_TEST ',A,':  ',A,' = ',A)") &
    2548. 

  2548.           TRIM(pre_str), TRIM(name_str), TRIM(res_str)
    2549. 

  2549.         CALL wrf_debug( 0, TRIM(out_str) )
    2550. 

  2550.       END SUBROUTINE domain_time_test_print
    2551. 

  2551. 

  2552.       ! Test adjust_io_timestr 
    2553. 

  2553.       SUBROUTINE test_adjust_io_timestr( TI_h, TI_m, TI_s, &
    2554. 

  2554.         CT_yy,  CT_mm,  CT_dd,  CT_h,  CT_m,  CT_s,        &
    2555. 

  2555.         ST_yy,  ST_mm,  ST_dd,  ST_h,  ST_m,  ST_s,        &
    2556. 

  2556.         res_str, testname )
    2557. 

  2557.         INTEGER, INTENT(IN) :: TI_H
    2558. 

  2558.         INTEGER, INTENT(IN) :: TI_M
    2559. 

  2559.         INTEGER, INTENT(IN) :: TI_S
    2560. 

  2560.         INTEGER, INTENT(IN) :: CT_YY
    2561. 

  2561.         INTEGER, INTENT(IN) :: CT_MM  ! month
    2562. 

  2562.         INTEGER, INTENT(IN) :: CT_DD  ! day of month
    2563. 

  2563.         INTEGER, INTENT(IN) :: CT_H
    2564. 

  2564.         INTEGER, INTENT(IN) :: CT_M
    2565. 

  2565.         INTEGER, INTENT(IN) :: CT_S
    2566. 

  2566.         INTEGER, INTENT(IN) :: ST_YY
    2567. 

  2567.         INTEGER, INTENT(IN) :: ST_MM  ! month
    2568. 

  2568.         INTEGER, INTENT(IN) :: ST_DD  ! day of month
    2569. 

  2569.         INTEGER, INTENT(IN) :: ST_H
    2570. 

  2570.         INTEGER, INTENT(IN) :: ST_M
    2571. 

  2571.         INTEGER, INTENT(IN) :: ST_S
    2572. 

  2572.         CHARACTER (LEN=*), INTENT(IN) :: res_str
    2573. 

  2573.         CHARACTER (LEN=*), INTENT(IN) :: testname
    2574. 

  2574.         ! locals
    2575. 

  2575.         TYPE(WRFU_TimeInterval) :: TI
    2576. 

  2576.         TYPE(WRFU_Time) :: CT, ST
    2577. 

  2577.         LOGICAL :: test_passed
    2578. 

  2578.         INTEGER :: rc
    2579. 

  2579.         CHARACTER(LEN=WRFU_MAXSTR) :: TI_str, CT_str, ST_str, computed_str
    2580. 

  2580.         ! TI
    2581. 

  2581.         CALL WRFU_TimeIntervalSet( TI, H=TI_H, M=TI_M, S=TI_S, rc=rc )
    2582. 

  2582.         CALL wrf_check_error( WRFU_SUCCESS, rc, &
    2583. 

  2583.                               'FAIL:  '//TRIM(testname)//'WRFU_TimeIntervalSet() ', &
    2584. 

  2584.                               __FILE__ , &
    2585. 

  2585.                               __LINE__  )
    2586. 

  2586.         CALL WRFU_TimeIntervalGet( TI, timeString=TI_str, rc=rc )
    2587. 

  2587.         CALL wrf_check_error( WRFU_SUCCESS, rc, &
    2588. 

  2588.                               'FAIL:  '//TRIM(testname)//'WRFU_TimeGet() ', &
    2589. 

  2589.                               __FILE__ , &
    2590. 

  2590.                               __LINE__  )
    2591. 

  2591.         ! CT
    2592. 

  2592.         CALL WRFU_TimeSet( CT, YY=CT_YY, MM=CT_MM, DD=CT_DD , &
    2593. 

  2593.                                 H=CT_H,   M=CT_M,   S=CT_S, rc=rc )
    2594. 

  2594.         CALL wrf_check_error( WRFU_SUCCESS, rc, &
    2595. 

  2595.                               'FAIL:  '//TRIM(testname)//'WRFU_TimeSet() ', &
    2596. 

  2596.                               __FILE__ , &
    2597. 

  2597.                               __LINE__  )
    2598. 

  2598.         CALL WRFU_TimeGet( CT, timeString=CT_str, rc=rc )
    2599. 

  2599.         CALL wrf_check_error( WRFU_SUCCESS, rc, &
    2600. 

  2600.                               'FAIL:  '//TRIM(testname)//'WRFU_TimeGet() ', &
    2601. 

  2601.                               __FILE__ , &
    2602. 

  2602.                               __LINE__  )
    2603. 

  2603.         ! ST
    2604. 

  2604.         CALL WRFU_TimeSet( ST, YY=ST_YY, MM=ST_MM, DD=ST_DD , &
    2605. 

  2605.                                 H=ST_H,   M=ST_M,   S=ST_S, rc=rc )
    2606. 

  2606.         CALL wrf_check_error( WRFU_SUCCESS, rc, &
    2607. 

  2607.                               'FAIL:  '//TRIM(testname)//'WRFU_TimeSet() ', &
    2608. 

  2608.                               __FILE__ , &
    2609. 

  2609.                               __LINE__  )
    2610. 

  2610.         CALL WRFU_TimeGet( ST, timeString=ST_str, rc=rc )
    2611. 

  2611.         CALL wrf_check_error( WRFU_SUCCESS, rc, &
    2612. 

  2612.                               'FAIL:  '//TRIM(testname)//'WRFU_TimeGet() ', &
    2613. 

  2613.                               __FILE__ , &
    2614. 

  2614.                               __LINE__  )
    2615. 

  2615.         ! Test
    2616. 

  2616.         CALL adjust_io_timestr ( TI, CT, ST, computed_str )
    2617. 

  2617.         ! check result
    2618. 

  2618.         test_passed = .FALSE.
    2619. 

  2619.         IF ( LEN_TRIM(res_str) == LEN_TRIM(computed_str) ) THEN
    2620. 

  2620.           IF ( res_str(1:LEN_TRIM(res_str)) == computed_str(1:LEN_TRIM(computed_str)) ) THEN
    2621. 

  2621.             test_passed = .TRUE.
    2622. 

  2622.           ENDIF
    2623. 

  2623.         ENDIF
    2624. 

  2624.         ! print result
    2625. 

  2625.         IF ( test_passed ) THEN
    2626. 

  2626.           WRITE(*,FMT='(A)') 'PASS:  '//TRIM(testname)
    2627. 

  2627.         ELSE
    2628. 

  2628.           WRITE(*,*) 'FAIL:  ',TRIM(testname),':  adjust_io_timestr(',    &
    2629. 

  2629.             TRIM(TI_str),',',TRIM(CT_str),',',TRIM(ST_str),')  expected <', &
    2630. 

  2630.             TRIM(res_str),'>  but computed <',TRIM(computed_str),'>'
    2631. 

  2631.         ENDIF
    2632. 

  2632.       END SUBROUTINE test_adjust_io_timestr
    2633. 

  2633. 

  2634.       ! Print lots of time-related information for testing and debugging.  
    2635. 

  2635.       ! Printed lines include pre_str and special string DOMAIN_TIME_TEST 
    2636. 

  2636.       ! suitable for grepping by test scripts.  
    2637. 

  2637.       ! Returns immediately unless self_test_domain has been set to .true. in 
    2638. 

  2638.       ! namelist /time_control/ .  
    2639. 

  2639.       SUBROUTINE domain_time_test ( grid, pre_str )
    2640. 

  2640.         IMPLICIT NONE
    2641. 

  2641.         TYPE(domain),      INTENT(IN) :: grid
    2642. 

  2642.         CHARACTER (LEN=*), INTENT(IN) :: pre_str
    2643. 

  2643.         ! locals
    2644. 

  2644.         LOGICAL, SAVE :: one_time_tests_done = .FALSE.
    2645. 

  2645.         REAL :: minutesSinceSimulationStart
    2646. 

  2646.         INTEGER :: advance_count, rc
    2647. 

  2647.         REAL :: currentDayOfYearReal
    2648. 

  2648.         TYPE(WRFU_TimeInterval) :: timeSinceSimulationStart
    2649. 

  2649.         TYPE(WRFU_Time) :: simulationStartTime
    2650. 

  2650.         CHARACTER (LEN=512) :: res_str
    2651. 

  2651.         LOGICAL :: self_test_domain
    2652. 

  2652.         !
    2653. 

  2653.         ! NOTE:  test_adjust_io_timestr() (see below) is a self-test that 
    2654. 

  2654.         !        prints PASS/FAIL/ERROR messages in a standard format.  All 
    2655. 

  2655.         !        of the other tests should be strucutred the same way, 
    2656. 

  2656.         !        someday.  
    2657. 

  2657.         !
    2658. 

  2658.         CALL nl_get_self_test_domain( 1, self_test_domain )
    2659. 

  2659.         IF ( self_test_domain ) THEN
    2660. 

  2660.           CALL domain_clock_get( grid, advanceCount=advance_count )
    2661. 

  2661.           WRITE ( res_str, FMT="(I8.8)" ) advance_count
    2662. 

  2662.           CALL domain_time_test_print( pre_str, 'advanceCount', res_str )
    2663. 

  2663.           CALL domain_clock_get( grid, currentDayOfYearReal=currentDayOfYearReal )
    2664. 

  2664.           WRITE ( res_str, FMT='(F10.6)' ) currentDayOfYearReal
    2665. 

  2665.           CALL domain_time_test_print( pre_str, 'currentDayOfYearReal', res_str )
    2666. 

  2666.           CALL domain_clock_get( grid, minutesSinceSimulationStart=minutesSinceSimulationStart )
    2667. 

  2667.           WRITE ( res_str, FMT='(F10.6)' ) minutesSinceSimulationStart
    2668. 

  2668.           CALL domain_time_test_print( pre_str, 'minutesSinceSimulationStart', res_str )
    2669. 

  2669.           CALL domain_clock_get( grid, current_timestr=res_str )
    2670. 

  2670.           CALL domain_time_test_print( pre_str, 'current_timestr', res_str )
    2671. 

  2671.           CALL domain_clock_get( grid, current_timestr_frac=res_str )
    2672. 

  2672.           CALL domain_time_test_print( pre_str, 'current_timestr_frac', res_str )
    2673. 

  2673.           CALL domain_clock_get( grid, timeSinceSimulationStart=timeSinceSimulationStart )
    2674. 

  2674.           CALL WRFU_TimeIntervalGet( timeSinceSimulationStart, timeString=res_str, rc=rc )
    2675. 

  2675.           IF ( rc /= WRFU_SUCCESS ) THEN
    2676. 

  2676.             CALL wrf_error_fatal ( &
    2677. 

  2677.               'domain_time_test:  WRFU_TimeIntervalGet() failed' )
    2678. 

  2678.           ENDIF
    2679. 

  2679.           CALL domain_time_test_print( pre_str, 'timeSinceSimulationStart', res_str )
    2680. 

  2680.           ! The following tests should only be done once, the first time this 
    2681. 

  2681.           ! routine is called.  
    2682. 

  2682.           IF ( .NOT. one_time_tests_done ) THEN
    2683. 

  2683.             one_time_tests_done = .TRUE.
    2684. 

  2684.             CALL domain_clock_get( grid, simulationStartTimeStr=res_str )
    2685. 

  2685.             CALL domain_time_test_print( pre_str, 'simulationStartTime', res_str )
    2686. 

  2686.             CALL domain_clock_get( grid, start_timestr=res_str )
    2687. 

  2687.             CALL domain_time_test_print( pre_str, 'start_timestr', res_str )
    2688. 

  2688.             CALL domain_clock_get( grid, stop_timestr=res_str )
    2689. 

  2689.             CALL domain_time_test_print( pre_str, 'stop_timestr', res_str )
    2690. 

  2690.             CALL domain_clock_get( grid, time_stepstr=res_str )
    2691. 

  2691.             CALL domain_time_test_print( pre_str, 'time_stepstr', res_str )
    2692. 

  2692.             CALL domain_clock_get( grid, time_stepstr_frac=res_str )
    2693. 

  2693.             CALL domain_time_test_print( pre_str, 'time_stepstr_frac', res_str )
    2694. 

  2694.             ! Test adjust_io_timestr()
    2695. 

  2695.             !     CT = 2000-01-26_00:00:00   (current time)
    2696. 

  2696.             !     ST = 2000-01-24_12:00:00   (start time)
    2697. 

  2697.             !     TI = 00000_03:00:00        (time interval)
    2698. 

  2698.             ! the resulting time string should be:
    2699. 

  2699.             !     2000-01-26_00:00:00
    2700. 

  2700.             CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0,          &
    2701. 

  2701.               CT_yy=2000,  CT_mm=1,  CT_dd=26,  CT_h=0,  CT_m=0,  CT_s=0, &
    2702. 

  2702.               ST_yy=2000,  ST_mm=1,  ST_dd=24,  ST_h=12, ST_m=0,  ST_s=0, &
    2703. 

  2703.               res_str='2000-01-26_00:00:00', testname='adjust_io_timestr_1' )
    2704. 

  2704.             ! this should fail (and does)
    2705. 

  2705.             !  CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0,          &
    2706. 

  2706.             !    CT_yy=2000,  CT_mm=1,  CT_dd=26,  CT_h=0,  CT_m=0,  CT_s=0, &
    2707. 

  2707.             !    ST_yy=2000,  ST_mm=1,  ST_dd=24,  ST_h=12, ST_m=0,  ST_s=0, &
    2708. 

  2708.             !    res_str='2000-01-26_00:00:01', testname='adjust_io_timestr_FAIL1' )
    2709. 

  2709.           ENDIF
    2710. 

  2710.         ENDIF
    2711. 

  2711.         RETURN
    2712. 

  2712.       END SUBROUTINE domain_time_test
    2713. 

  2713. 

  2714. !******************************************************************************
    2715. 

  2715. ! END TEST SECTION
    2716. 

  2716. !******************************************************************************
    2717. 

  2717. 

  2718. 

  2719. END MODULE module_domain
    2720. 

  2720. 

  2721. 

  2722. ! The following routines are outside this module to avoid build dependences.  
    2723. 

  2723. 

  2724. 

  2725. ! Get current time as a string (current time from clock attached to the 
    2726. 

  2726. ! current_grid).  Includes fractional part, if present.  
    2727. 

  2727. ! Returns empty string if current_grid is not set or if timing has not yet 
    2728. 

  2728. ! been set up on current_grid.  
    2729. 

  2729. SUBROUTINE get_current_time_string( time_str )
    2730. 

  2730.   USE module_domain
    2731. 

  2731.   IMPLICIT NONE
    2732. 

  2732.   CHARACTER (LEN=*), INTENT(OUT) :: time_str
    2733. 

  2733.   ! locals
    2734. 

  2734.   INTEGER :: debug_level_lcl
    2735. 

  2735. !PRINT *,'DEBUG:  begin get_current_time_string()'
    2736. 

  2736.   time_str = ''
    2737. 

  2737.   IF ( current_grid_set ) THEN
    2738. 

  2738. !$$$DEBUG
    2739. 

  2739. !PRINT *,'DEBUG:  get_current_time_string():  checking association of current_grid...'
    2740. 

  2740. !IF ( ASSOCIATED( current_grid ) ) THEN
    2741. 

  2741. !  PRINT *,'DEBUG:  get_current_time_string():  current_grid is associated'
    2742. 

  2742. !ELSE
    2743. 

  2743. !  PRINT *,'DEBUG:  get_current_time_string():  current_grid is NOT associated'
    2744. 

  2744. !ENDIF
    2745. 

  2745. !$$$END DEBUG
    2746. 

  2746.     IF ( current_grid%time_set ) THEN
    2747. 

  2747. !PRINT *,'DEBUG:  get_current_time_string():  calling domain_clock_get()'
    2748. 

  2748.       ! set debug_level to zero and clear current_grid_set to avoid recursion
    2749. 

  2749.       CALL get_wrf_debug_level( debug_level_lcl )
    2750. 

  2750.       CALL set_wrf_debug_level ( 0 )
    2751. 

  2751.       current_grid_set = .FALSE.
    2752. 

  2752.       CALL domain_clock_get( current_grid, current_timestr_frac=time_str )
    2753. 

  2753.       ! restore debug_level and current_grid_set
    2754. 

  2754.       CALL set_wrf_debug_level ( debug_level_lcl )
    2755. 

  2755.       current_grid_set = .TRUE.
    2756. 

  2756. !PRINT *,'DEBUG:  get_current_time_string():  back from domain_clock_get()'
    2757. 

  2757.     ENDIF
    2758. 

  2758.   ENDIF
    2759. 

  2759. !PRINT *,'DEBUG:  end get_current_time_string()'
    2760. 

  2760. END SUBROUTINE get_current_time_string
    2761. 

  2761. 

  2762. 

  2763. ! Get current domain name as a string of form "d<NN>" where "<NN>" is 
    2764. 

  2764. ! grid%id printed in two characters, with leading zero if needed ("d01", 
    2765. 

  2765. ! "d02", etc.).  
    2766. 

  2766. ! Return empty string if current_grid not set.  
    2767. 

  2767. SUBROUTINE get_current_grid_name( grid_str )
    2768. 

  2768.   USE module_domain
    2769. 

  2769.   IMPLICIT NONE
    2770. 

  2770.   CHARACTER (LEN=*), INTENT(OUT) :: grid_str
    2771. 

  2771.   grid_str = ''
    2772. 

  2772.   IF ( current_grid_set ) THEN
    2773. 

  2773.     WRITE(grid_str,FMT="('d',I2.2)") current_grid%id
    2774. 

  2774.   ENDIF
    2775. 

  2775. END SUBROUTINE get_current_grid_name
    2776. 

  2776. 

  2777. 

  2778. ! moved these outside module domain to avoid circular reference from module_alloc_space which also uses
    2779. 

  2779. 

  2780.    SUBROUTINE get_ijk_from_grid_ext (  grid ,                   &
    2781. 

  2781.                            ids, ide, jds, jde, kds, kde,    &
    2782. 

  2782.                            ims, ime, jms, jme, kms, kme,    &
    2783. 

  2783.                            ips, ipe, jps, jpe, kps, kpe,    &
    2784. 

  2784.                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
    2785. 

  2785.                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
    2786. 

  2786.                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
    2787. 

  2787.                            ipsy, ipey, jpsy, jpey, kpsy, kpey )
    2788. 

  2788.     USE module_domain
    2789. 

  2789.     IMPLICIT NONE
    2790. 

  2790.     TYPE( domain ), INTENT (IN)  :: grid
    2791. 

  2791.     INTEGER, INTENT(OUT) ::                                 &
    2792. 

  2792.                            ids, ide, jds, jde, kds, kde,    &
    2793. 

  2793.                            ims, ime, jms, jme, kms, kme,    &
    2794. 

  2794.                            ips, ipe, jps, jpe, kps, kpe,    &
    2795. 

  2795.                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
    2796. 

  2796.                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
    2797. 

  2797.                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
    2798. 

  2798.                            ipsy, ipey, jpsy, jpey, kpsy, kpey
    2799. 

  2799. 

  2800.      CALL get_ijk_from_grid2 (  grid ,                   &
    2801. 

  2801.                            ids, ide, jds, jde, kds, kde,    &
    2802. 

  2802.                            ims, ime, jms, jme, kms, kme,    &
    2803. 

  2803.                            ips, ipe, jps, jpe, kps, kpe )
    2804. 

  2804.      data_ordering : SELECT CASE ( model_data_order )
    2805. 

  2805.        CASE  ( DATA_ORDER_XYZ )
    2806. 

  2806.            imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
    2807. 

  2807.            ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
    2808. 

  2808.            imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
    2809. 

  2809.            ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
    2810. 

  2810.        CASE  ( DATA_ORDER_YXZ )
    2811. 

  2811.            imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
    2812. 

  2812.            ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
    2813. 

  2813.            imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
    2814. 

  2814.            ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
    2815. 

  2815.        CASE  ( DATA_ORDER_ZXY )
    2816. 

  2816.            imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
    2817. 

  2817.            ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
    2818. 

  2818.            imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
    2819. 

  2819.            ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
    2820. 

  2820.        CASE  ( DATA_ORDER_ZYX )
    2821. 

  2821.            imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
    2822. 

  2822.            ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
    2823. 

  2823.            imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
    2824. 

  2824.            ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
    2825. 

  2825.        CASE  ( DATA_ORDER_XZY )
    2826. 

  2826.            imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
    2827. 

  2827.            ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
    2828. 

  2828.            imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
    2829. 

  2829.            ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
    2830. 

  2830.        CASE  ( DATA_ORDER_YZX )
    2831. 

  2831.            imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
    2832. 

  2832.            ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
    2833. 

  2833.            imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
    2834. 

  2834.            ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
    2835. 

  2835.      END SELECT data_ordering
    2836. 

  2836.    END SUBROUTINE get_ijk_from_grid_ext
    2837. 

  2837. 

  2838. ! return the values for subgrid whose refinement is in grid%sr
    2839. 

  2839. ! note when using this routine, it does not affect K. For K 
    2840. 

  2840. ! (vertical), it just returns what get_ijk_from_grid does
    2841. 

  2841.    SUBROUTINE get_ijk_from_subgrid_ext (  grid ,                &
    2842. 

  2842.                            ids0, ide0, jds0, jde0, kds0, kde0,    &
    2843. 

  2843.                            ims0, ime0, jms0, jme0, kms0, kme0,    &
    2844. 

  2844.                            ips0, ipe0, jps0, jpe0, kps0, kpe0    )
    2845. 

  2845.     USE module_domain
    2846. 

  2846.     IMPLICIT NONE
    2847. 

  2847.     TYPE( domain ), INTENT (IN)  :: grid
    2848. 

  2848.     INTEGER, INTENT(OUT) ::                                 &
    2849. 

  2849.                            ids0, ide0, jds0, jde0, kds0, kde0,    &
    2850. 

  2850.                            ims0, ime0, jms0, jme0, kms0, kme0,    &
    2851. 

  2851.                            ips0, ipe0, jps0, jpe0, kps0, kpe0
    2852. 

  2852.    ! Local
    2853. 

  2853.     INTEGER              ::                                 &
    2854. 

  2854.                            ids, ide, jds, jde, kds, kde,    &
    2855. 

  2855.                            ims, ime, jms, jme, kms, kme,    &
    2856. 

  2856.                            ips, ipe, jps, jpe, kps, kpe
    2857. 

  2857.      CALL get_ijk_from_grid (  grid ,                         &
    2858. 

  2858.                              ids, ide, jds, jde, kds, kde,    &
    2859. 

  2859.                              ims, ime, jms, jme, kms, kme,    &
    2860. 

  2860.                              ips, ipe, jps, jpe, kps, kpe    )
    2861. 

  2861.      ids0 = ids
    2862. 

  2862.      ide0 = ide * grid%sr_x
    2863. 

  2863.      ims0 = (ims-1)*grid%sr_x+1
    2864. 

  2864.      ime0 = ime * grid%sr_x
    2865. 

  2865.      ips0 = (ips-1)*grid%sr_x+1
    2866. 

  2866.      ipe0 = ipe * grid%sr_x
    2867. 

  2867. 

  2868.      jds0 = jds
    2869. 

  2869.      jde0 = jde * grid%sr_y
    2870. 

  2870.      jms0 = (jms-1)*grid%sr_y+1
    2871. 

  2871.      jme0 = jme * grid%sr_y
    2872. 

  2872.      jps0 = (jps-1)*grid%sr_y+1
    2873. 

  2873.      jpe0 = jpe * grid%sr_y
    2874. 

  2874. 

  2875.      kds0 = kds
    2876. 

  2876.      kde0 = kde
    2877. 

  2877.      kms0 = kms
    2878. 

  2878.      kme0 = kme
    2879. 

  2879.      kps0 = kps
    2880. 

  2880.      kpe0 = kpe
    2881. 

  2881.    RETURN
    2882. 

  2882.    END SUBROUTINE get_ijk_from_subgrid_ext
    2883. 

  2883. 

  2884. ! find the grid based on the id reference and return that
    2885. 

  2885.    SUBROUTINE get_dims_from_grid_id (  id   &
    2886. 

  2886.                           ,ds, de           &
    2887. 

  2887.                           ,ms, me           &
    2888. 

  2888.                           ,ps, pe           &
    2889. 

  2889.                           ,mxs, mxe         &
    2890. 

  2890.                           ,pxs, pxe         &
    2891. 

  2891.                           ,mys, mye         &
    2892. 

  2892.                           ,pys, pye )
    2893. 

  2893.     USE module_domain, ONLY : domain, head_grid, find_grid_by_id
    2894. 

  2894.     IMPLICIT NONE
    2895. 

  2895.     TYPE( domain ), POINTER  :: grid
    2896. 

  2896.     INTEGER, INTENT(IN ) :: id
    2897. 

  2897.     INTEGER, DIMENSION(3), INTENT(INOUT) ::                   &
    2898. 

  2898.                            ds, de           &
    2899. 

  2899.                           ,ms, me           &
    2900. 

  2900.                           ,ps, pe           &
    2901. 

  2901.                           ,mxs, mxe         &
    2902. 

  2902.                           ,pxs, pxe         &
    2903. 

  2903.                           ,mys, mye         &
    2904. 

  2904.                           ,pys, pye
    2905. 

  2905. 

  2906.      !local
    2907. 

  2907.      CHARACTER*256 mess
    2908. 

  2908. 

  2909.      NULLIFY( grid )
    2910. 

  2910.      CALL find_grid_by_id ( id, head_grid, grid )
    2911. 

  2911. 

  2912.      IF ( ASSOCIATED(grid) ) THEN
    2913. 

  2913.            ds(1) = grid%sd31 ; de(1) = grid%ed31 ; ds(2) = grid%sd32 ; de(2) = grid%ed32 ; ds(3) = grid%sd33 ; de(3) = grid%ed33 ;
    2914. 

  2914.            ms(1) = grid%sm31 ; me(1) = grid%em31 ; ms(2) = grid%sm32 ; me(2) = grid%em32 ; ms(3) = grid%sm33 ; me(3) = grid%em33 ;
    2915. 

  2915.            ps(1) = grid%sp31 ; pe(1) = grid%ep31 ; ps(2) = grid%sp32 ; pe(2) = grid%ep32 ; ps(3) = grid%sp33 ; pe(3) = grid%ep33 ;
    2916. 

  2916.            mxs(1) = grid%sm31x ; mxe(1) = grid%em31x 
    2917. 

  2917.            mxs(2) = grid%sm32x ; mxe(2) = grid%em32x 
    2918. 

  2918.            mxs(3) = grid%sm33x ; mxe(3) = grid%em33x 
    2919. 

  2919.            pxs(1) = grid%sp31x ; pxe(1) = grid%ep31x 
    2920. 

  2920.            pxs(2) = grid%sp32x ; pxe(2) = grid%ep32x 
    2921. 

  2921.            pxs(3) = grid%sp33x ; pxe(3) = grid%ep33x
    2922. 

  2922.            mys(1) = grid%sm31y ; mye(1) = grid%em31y 
    2923. 

  2923.            mys(2) = grid%sm32y ; mye(2) = grid%em32y 
    2924. 

  2924.            mys(3) = grid%sm33y ; mye(3) = grid%em33y 
    2925. 

  2925.            pys(1) = grid%sp31y ; pye(1) = grid%ep31y 
    2926. 

  2926.            pys(2) = grid%sp32y ; pye(2) = grid%ep32y 
    2927. 

  2927.            pys(3) = grid%sp33y ; pye(3) = grid%ep33y 
    2928. 

  2928.      ELSE
    2929. 

  2929.         WRITE(mess,*)'internal error: get_ijk_from_grid_id: no such grid id:',id
    2930. 

  2930.         CALL wrf_error_fatal(TRIM(mess))
    2931. 

  2931.      ENDIF
    2932. 

  2932. 

  2933.    END SUBROUTINE get_dims_from_grid_id
    2934. 

  2934. 

  2935. ! find the grid based on the id reference and return that
    2936. 

  2936.    SUBROUTINE get_ijk_from_grid_id (  id ,                   &
    2937. 

  2937.                            ids, ide, jds, jde, kds, kde,    &
    2938. 

  2938.                            ims, ime, jms, jme, kms, kme,    &
    2939. 

  2939.                            ips, ipe, jps, jpe, kps, kpe,    &
    2940. 

  2940.                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
    2941. 

  2941.                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
    2942. 

  2942.                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
    2943. 

  2943.                            ipsy, ipey, jpsy, jpey, kpsy, kpey )
    2944. 

  2944.     USE module_domain, ONLY : domain, head_grid, find_grid_by_id, get_ijk_from_grid
    2945. 

  2945.     IMPLICIT NONE
    2946. 

  2946.     TYPE( domain ), POINTER  :: grid
    2947. 

  2947.     INTEGER, INTENT(IN ) :: id
    2948. 

  2948.     INTEGER, INTENT(OUT) ::                                 &
    2949. 

  2949.                            ids, ide, jds, jde, kds, kde,    &
    2950. 

  2950.                            ims, ime, jms, jme, kms, kme,    &
    2951. 

  2951.                            ips, ipe, jps, jpe, kps, kpe,    &
    2952. 

  2952.                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
    2953. 

  2953.                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
    2954. 

  2954.                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
    2955. 

  2955.                            ipsy, ipey, jpsy, jpey, kpsy, kpey
    2956. 

  2956.      !local
    2957. 

  2957.      CHARACTER*256 mess
    2958. 

  2958. 

  2959.      NULLIFY( grid )
    2960. 

  2960.      CALL find_grid_by_id ( id, head_grid, grid )
    2961. 

  2961. 

  2962.      IF ( ASSOCIATED(grid) ) THEN
    2963. 

  2963.      CALL get_ijk_from_grid (  grid ,                   &
    2964. 

  2964.                            ids, ide, jds, jde, kds, kde,    &
    2965. 

  2965.                            ims, ime, jms, jme, kms, kme,    &
    2966. 

  2966.                            ips, ipe, jps, jpe, kps, kpe,    &
    2967. 

  2967.                            imsx, imex, jmsx, jmex, kmsx, kmex,    &
    2968. 

  2968.                            ipsx, ipex, jpsx, jpex, kpsx, kpex,    &
    2969. 

  2969.                            imsy, imey, jmsy, jmey, kmsy, kmey,    &
    2970. 

  2970.                            ipsy, ipey, jpsy, jpey, kpsy, kpey )
    2971. 

  2971.      ELSE
    2972. 

  2972.         WRITE(mess,*)'internal error: get_ijk_from_grid_id: no such grid id:',id
    2973. 

  2973.         CALL wrf_error_fatal(TRIM(mess))
    2974. 

  2974.      ENDIF
    2975. 

  2975. 

  2976.    END SUBROUTINE get_ijk_from_grid_id
    2977. 

  2977. 

  2978. ! version of this routine that can be called from set_scalar_indices_from_config in
    2979. 

  2979. ! module_configure, which can not USE module_domain without creating a circular use assocaition
    2980. 

  2980.    SUBROUTINE modify_io_masks ( id )
    2981. 

  2981.      USE module_domain, ONLY : domain, modify_io_masks1, head_grid, find_grid_by_id
    2982. 

  2982.      IMPLICIT NONE
    2983. 

  2983.      INTEGER, INTENT(IN) :: id
    2984. 

  2984.      TYPE(domain), POINTER :: grid
    2985. 

  2985. !write(0,*)'modify_io_masks head_grid ',id,ASSOCIATED(head_grid)
    2986. 

  2986.      CALL find_grid_by_id( id, head_grid, grid )
    2987. 

  2987. !write(0,*)'modify_io_masks grid ',id,ASSOCIATED(grid)
    2988. 

  2988.      IF ( ASSOCIATED( grid ) ) CALL modify_io_masks1( grid, id ) 
    2989. 

  2989.      RETURN 
    2990. 

  2990.    END SUBROUTINE modify_io_masks
    2991. 

  2991. 

  2992.