1 !WRF:DRIVER_LAYER:DOMAIN_OBJECT
3 ! Following are the routines contained within this MODULE:
5 ! alloc_and_configure_domain 1. Allocate the space for a single domain (constants
6 ! and null terminate pointers).
7 ! 2. Connect the domains as a linked list.
8 ! 3. Store all of the domain constants.
9 ! 4. CALL alloc_space_field.
11 ! alloc_space_field 1. Allocate space for the gridded data required for
14 ! dealloc_space_domain 1. Reconnect linked list nodes since the current
16 ! 2. CALL dealloc_space_field.
17 ! 3. Deallocate single domain.
19 ! dealloc_space_field 1. Deallocate each of the fields for a particular
22 ! first_loc_integer 1. Find the first incidence of a particular
23 ! domain identifier from an array of domain
28 USE module_driver_constants
33 USE module_domain_type
35 ! In WRFV3, the module_domain_type is defined
36 ! in a separaate source file, frame/module_domain_type.F
37 ! This enables splitting off the alloc_space_field routine
38 ! into a separate file, reducing the size of module_domain
40 ! Now that a "domain" TYPE exists, we can use it to store a few pointers
41 ! to this type. These are primarily for use in traversing the linked list.
42 ! The "head_grid" is always the pointer to the first domain that is
43 ! allocated. This is available and is not to be changed. The others are
44 ! just temporary pointers.
46 TYPE(domain) , POINTER :: head_grid , new_grid , next_grid , old_grid
48 ! To facilitate an easy integration of each of the domains that are on the
49 ! same level, we have an array for the head pointer for each level. This
50 ! removed the need to search through the linked list at each time step to
51 ! find which domains are to be active.
54 TYPE(domain) , POINTER :: first_domain
55 END TYPE domain_levels
57 TYPE(domain_levels) , DIMENSION(max_levels) :: head_for_each_level
59 ! Use this to support debugging features, giving easy access to clock, etc.
60 TYPE(domain), POINTER :: current_grid
61 LOGICAL, SAVE :: current_grid_set = .FALSE.
64 PRIVATE domain_time_test_print
65 PRIVATE test_adjust_io_timestr
67 INTERFACE get_ijk_from_grid
68 MODULE PROCEDURE get_ijk_from_grid1, get_ijk_from_grid2
74 SUBROUTINE adjust_domain_dims_for_move( grid , dx, dy )
77 TYPE( domain ), POINTER :: grid
78 INTEGER, INTENT(IN) :: dx, dy
80 data_ordering : SELECT CASE ( model_data_order )
81 CASE ( DATA_ORDER_XYZ )
82 grid%sm31 = grid%sm31 + dx
83 grid%em31 = grid%em31 + dx
84 grid%sm32 = grid%sm32 + dy
85 grid%em32 = grid%em32 + dy
86 grid%sp31 = grid%sp31 + dx
87 grid%ep31 = grid%ep31 + dx
88 grid%sp32 = grid%sp32 + dy
89 grid%ep32 = grid%ep32 + dy
90 grid%sd31 = grid%sd31 + dx
91 grid%ed31 = grid%ed31 + dx
92 grid%sd32 = grid%sd32 + dy
93 grid%ed32 = grid%ed32 + dy
95 CASE ( DATA_ORDER_YXZ )
96 grid%sm31 = grid%sm31 + dy
97 grid%em31 = grid%em31 + dy
98 grid%sm32 = grid%sm32 + dx
99 grid%em32 = grid%em32 + dx
100 grid%sp31 = grid%sp31 + dy
101 grid%ep31 = grid%ep31 + dy
102 grid%sp32 = grid%sp32 + dx
103 grid%ep32 = grid%ep32 + dx
104 grid%sd31 = grid%sd31 + dy
105 grid%ed31 = grid%ed31 + dy
106 grid%sd32 = grid%sd32 + dx
107 grid%ed32 = grid%ed32 + dx
109 CASE ( DATA_ORDER_ZXY )
110 grid%sm32 = grid%sm32 + dx
111 grid%em32 = grid%em32 + dx
112 grid%sm33 = grid%sm33 + dy
113 grid%em33 = grid%em33 + dy
114 grid%sp32 = grid%sp32 + dx
115 grid%ep32 = grid%ep32 + dx
116 grid%sp33 = grid%sp33 + dy
117 grid%ep33 = grid%ep33 + dy
118 grid%sd32 = grid%sd32 + dx
119 grid%ed32 = grid%ed32 + dx
120 grid%sd33 = grid%sd33 + dy
121 grid%ed33 = grid%ed33 + dy
123 CASE ( DATA_ORDER_ZYX )
124 grid%sm32 = grid%sm32 + dy
125 grid%em32 = grid%em32 + dy
126 grid%sm33 = grid%sm33 + dx
127 grid%em33 = grid%em33 + dx
128 grid%sp32 = grid%sp32 + dy
129 grid%ep32 = grid%ep32 + dy
130 grid%sp33 = grid%sp33 + dx
131 grid%ep33 = grid%ep33 + dx
132 grid%sd32 = grid%sd32 + dy
133 grid%ed32 = grid%ed32 + dy
134 grid%sd33 = grid%sd33 + dx
135 grid%ed33 = grid%ed33 + dx
137 CASE ( DATA_ORDER_XZY )
138 grid%sm31 = grid%sm31 + dx
139 grid%em31 = grid%em31 + dx
140 grid%sm33 = grid%sm33 + dy
141 grid%em33 = grid%em33 + dy
142 grid%sp31 = grid%sp31 + dx
143 grid%ep31 = grid%ep31 + dx
144 grid%sp33 = grid%sp33 + dy
145 grid%ep33 = grid%ep33 + dy
146 grid%sd31 = grid%sd31 + dx
147 grid%ed31 = grid%ed31 + dx
148 grid%sd33 = grid%sd33 + dy
149 grid%ed33 = grid%ed33 + dy
151 CASE ( DATA_ORDER_YZX )
152 grid%sm31 = grid%sm31 + dy
153 grid%em31 = grid%em31 + dy
154 grid%sm33 = grid%sm33 + dx
155 grid%em33 = grid%em33 + dx
156 grid%sp31 = grid%sp31 + dy
157 grid%ep31 = grid%ep31 + dy
158 grid%sp33 = grid%sp33 + dx
159 grid%ep33 = grid%ep33 + dx
160 grid%sd31 = grid%sd31 + dy
161 grid%ed31 = grid%ed31 + dy
162 grid%sd33 = grid%sd33 + dx
163 grid%ed33 = grid%ed33 + dx
165 END SELECT data_ordering
168 CALL dealloc_space_field ( grid )
170 CALL alloc_space_field ( grid, grid%id , 1 , 2 , .FALSE. , &
171 grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
172 grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, &
173 grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose
174 grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose
179 END SUBROUTINE adjust_domain_dims_for_move
181 SUBROUTINE get_ijk_from_grid1 ( grid , &
182 ids, ide, jds, jde, kds, kde, &
183 ims, ime, jms, jme, kms, kme, &
184 ips, ipe, jps, jpe, kps, kpe, &
185 imsx, imex, jmsx, jmex, kmsx, kmex, &
186 ipsx, ipex, jpsx, jpex, kpsx, kpex, &
187 imsy, imey, jmsy, jmey, kmsy, kmey, &
188 ipsy, ipey, jpsy, jpey, kpsy, kpey )
190 TYPE( domain ), INTENT (IN) :: grid
191 INTEGER, INTENT(OUT) :: &
192 ids, ide, jds, jde, kds, kde, &
193 ims, ime, jms, jme, kms, kme, &
194 ips, ipe, jps, jpe, kps, kpe, &
195 imsx, imex, jmsx, jmex, kmsx, kmex, &
196 ipsx, ipex, jpsx, jpex, kpsx, kpex, &
197 imsy, imey, jmsy, jmey, kmsy, kmey, &
198 ipsy, ipey, jpsy, jpey, kpsy, kpey
200 CALL get_ijk_from_grid2 ( grid , &
201 ids, ide, jds, jde, kds, kde, &
202 ims, ime, jms, jme, kms, kme, &
203 ips, ipe, jps, jpe, kps, kpe )
204 data_ordering : SELECT CASE ( model_data_order )
205 CASE ( DATA_ORDER_XYZ )
206 imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
207 ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
208 imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
209 ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
210 CASE ( DATA_ORDER_YXZ )
211 imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
212 ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
213 imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
214 ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
215 CASE ( DATA_ORDER_ZXY )
216 imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
217 ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
218 imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
219 ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
220 CASE ( DATA_ORDER_ZYX )
221 imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
222 ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
223 imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
224 ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
225 CASE ( DATA_ORDER_XZY )
226 imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
227 ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
228 imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
229 ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
230 CASE ( DATA_ORDER_YZX )
231 imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
232 ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
233 imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
234 ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
235 END SELECT data_ordering
236 END SUBROUTINE get_ijk_from_grid1
238 SUBROUTINE get_ijk_from_grid2 ( grid , &
239 ids, ide, jds, jde, kds, kde, &
240 ims, ime, jms, jme, kms, kme, &
241 ips, ipe, jps, jpe, kps, kpe )
245 TYPE( domain ), INTENT (IN) :: grid
246 INTEGER, INTENT(OUT) :: &
247 ids, ide, jds, jde, kds, kde, &
248 ims, ime, jms, jme, kms, kme, &
249 ips, ipe, jps, jpe, kps, kpe
251 data_ordering : SELECT CASE ( model_data_order )
252 CASE ( DATA_ORDER_XYZ )
253 ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd33 ; kde = grid%ed33 ;
254 ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm33 ; kme = grid%em33 ;
255 ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp33 ; kpe = grid%ep33 ;
256 CASE ( DATA_ORDER_YXZ )
257 ids = grid%sd32 ; ide = grid%ed32 ; jds = grid%sd31 ; jde = grid%ed31 ; kds = grid%sd33 ; kde = grid%ed33 ;
258 ims = grid%sm32 ; ime = grid%em32 ; jms = grid%sm31 ; jme = grid%em31 ; kms = grid%sm33 ; kme = grid%em33 ;
259 ips = grid%sp32 ; ipe = grid%ep32 ; jps = grid%sp31 ; jpe = grid%ep31 ; kps = grid%sp33 ; kpe = grid%ep33 ;
260 CASE ( DATA_ORDER_ZXY )
261 ids = grid%sd32 ; ide = grid%ed32 ; jds = grid%sd33 ; jde = grid%ed33 ; kds = grid%sd31 ; kde = grid%ed31 ;
262 ims = grid%sm32 ; ime = grid%em32 ; jms = grid%sm33 ; jme = grid%em33 ; kms = grid%sm31 ; kme = grid%em31 ;
263 ips = grid%sp32 ; ipe = grid%ep32 ; jps = grid%sp33 ; jpe = grid%ep33 ; kps = grid%sp31 ; kpe = grid%ep31 ;
264 CASE ( DATA_ORDER_ZYX )
265 ids = grid%sd33 ; ide = grid%ed33 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd31 ; kde = grid%ed31 ;
266 ims = grid%sm33 ; ime = grid%em33 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm31 ; kme = grid%em31 ;
267 ips = grid%sp33 ; ipe = grid%ep33 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp31 ; kpe = grid%ep31 ;
268 CASE ( DATA_ORDER_XZY )
269 ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd33 ; jde = grid%ed33 ; kds = grid%sd32 ; kde = grid%ed32 ;
270 ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm33 ; jme = grid%em33 ; kms = grid%sm32 ; kme = grid%em32 ;
271 ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp33 ; jpe = grid%ep33 ; kps = grid%sp32 ; kpe = grid%ep32 ;
272 CASE ( DATA_ORDER_YZX )
273 ids = grid%sd33 ; ide = grid%ed33 ; jds = grid%sd31 ; jde = grid%ed31 ; kds = grid%sd32 ; kde = grid%ed32 ;
274 ims = grid%sm33 ; ime = grid%em33 ; jms = grid%sm31 ; jme = grid%em31 ; kms = grid%sm32 ; kme = grid%em32 ;
275 ips = grid%sp33 ; ipe = grid%ep33 ; jps = grid%sp31 ; jpe = grid%ep31 ; kps = grid%sp32 ; kpe = grid%ep32 ;
276 END SELECT data_ordering
277 END SUBROUTINE get_ijk_from_grid2
279 ! return the values for subgrid whose refinement is in grid%sr
280 ! note when using this routine, it does not affect K. For K
281 ! (vertical), it just returns what get_ijk_from_grid does
282 SUBROUTINE get_ijk_from_subgrid ( grid , &
283 ids0, ide0, jds0, jde0, kds0, kde0, &
284 ims0, ime0, jms0, jme0, kms0, kme0, &
285 ips0, ipe0, jps0, jpe0, kps0, kpe0 )
286 TYPE( domain ), INTENT (IN) :: grid
287 INTEGER, INTENT(OUT) :: &
288 ids0, ide0, jds0, jde0, kds0, kde0, &
289 ims0, ime0, jms0, jme0, kms0, kme0, &
290 ips0, ipe0, jps0, jpe0, kps0, kpe0
293 ids, ide, jds, jde, kds, kde, &
294 ims, ime, jms, jme, kms, kme, &
295 ips, ipe, jps, jpe, kps, kpe
296 CALL get_ijk_from_grid ( grid , &
297 ids, ide, jds, jde, kds, kde, &
298 ims, ime, jms, jme, kms, kme, &
299 ips, ipe, jps, jpe, kps, kpe )
301 ide0 = ide * grid%sr_x
302 ims0 = (ims-1)*grid%sr_x+1
303 ime0 = ime * grid%sr_x
304 ips0 = (ips-1)*grid%sr_x+1
305 ipe0 = ipe * grid%sr_x
308 jde0 = jde * grid%sr_y
309 jms0 = (jms-1)*grid%sr_y+1
310 jme0 = jme * grid%sr_y
311 jps0 = (jps-1)*grid%sr_y+1
312 jpe0 = jpe * grid%sr_y
321 END SUBROUTINE get_ijk_from_subgrid
324 ! Default version ; Otherwise module containing interface to DM library will provide
326 SUBROUTINE wrf_patch_domain( id , domdesc , parent, parent_id , parent_domdesc , &
327 sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
328 sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
329 sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
330 sp1x , ep1x , sm1x , em1x , &
331 sp2x , ep2x , sm2x , em2x , &
332 sp3x , ep3x , sm3x , em3x , &
333 sp1y , ep1y , sm1y , em1y , &
334 sp2y , ep2y , sm2y , em2y , &
335 sp3y , ep3y , sm3y , em3y , &
336 bdx , bdy , bdy_mask )
338 ! Wrf_patch_domain is called as part of the process of initiating a new
339 ! domain. Based on the global domain dimension information that is
340 ! passed in it computes the patch and memory dimensions on this
341 ! distributed-memory process for parallel compilation when DM_PARALLEL is
342 ! defined in configure.wrf. In this case, it relies on an external
343 ! communications package-contributed routine, wrf_dm_patch_domain. For
344 ! non-parallel compiles, it returns the patch and memory dimensions based
345 ! on the entire domain. In either case, the memory dimensions will be
346 ! larger than the patch dimensions, since they allow for distributed
347 ! memory halo regions (DM_PARALLEL only) and for boundary regions around
348 ! the domain (used for idealized cases only). The width of the boundary
349 ! regions to be accommodated is passed in as bdx and bdy.
351 ! The bdy_mask argument is a four-dimensional logical array, each element
352 ! of which is set to true for any boundaries that this process's patch
353 ! contains (all four are true in the non-DM_PARALLEL case) and false
354 ! otherwise. The indices into the bdy_mask are defined in
355 ! frame/module_state_description.F. P_XSB corresponds boundary that
356 ! exists at the beginning of the X-dimension; ie. the western boundary;
357 ! P_XEB to the boundary that corresponds to the end of the X-dimension
358 ! (east). Likewise for Y (south and north respectively).
360 ! The correspondence of the first, second, and third dimension of each
361 ! set (domain, memory, and patch) with the coordinate axes of the model
362 ! domain is based on the setting of the variable model_data_order, which
363 ! comes into this routine through USE association of
364 ! module_driver_constants in the enclosing module of this routine,
365 ! module_domain. Model_data_order is defined by the Registry, based on
366 ! the dimspec entries which associate dimension specifiers (e.g. 'k') in
367 ! the Registry with a coordinate axis and specify which dimension of the
368 ! arrays they represent. For WRF, the sd1 , ed1 , sp1 , ep1 , sm1 , and
369 ! em1 correspond to the starts and ends of the global, patch, and memory
370 ! dimensions in X; those with 2 specify Z (vertical); and those with 3
371 ! specify Y. Note that the WRF convention is to overdimension to allow
372 ! for staggered fields so that sd<em>n</em>:ed<em>n</em> are the starts
373 ! and ends of the staggered domains in X. The non-staggered grid runs
374 ! sd<em>n</em>:ed<em>n</em>-1. The extra row or column on the north or
375 ! east boundaries is not used for non-staggered fields.
377 ! The domdesc and parent_domdesc arguments are for external communication
378 ! packages (e.g. RSL) that establish and return to WRF integer handles
379 ! for referring to operations on domains. These descriptors are not set
380 ! or used otherwise and they are opaque, which means they are never
381 ! accessed or modified in WRF; they are only only passed between calls to
382 ! the external package.
387 LOGICAL, DIMENSION(4), INTENT(OUT) :: bdy_mask
388 INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
389 INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , & ! z-xpose (std)
390 sm1 , em1 , sm2 , em2 , sm3 , em3
391 INTEGER, INTENT(OUT) :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , & ! x-xpose
392 sm1x , em1x , sm2x , em2x , sm3x , em3x
393 INTEGER, INTENT(OUT) :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , & ! y-xpose
394 sm1y , em1y , sm2y , em2y , sm3y , em3y
395 INTEGER, INTENT(IN) :: id , parent_id , parent_domdesc
396 INTEGER, INTENT(INOUT) :: domdesc
397 TYPE(domain), POINTER :: parent
401 INTEGER spec_bdy_width
403 CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
407 bdy_mask = .true. ! only one processor so all 4 boundaries are there
409 ! this is a trivial version -- 1 patch per processor;
410 ! use version in module_dm to compute for DM
411 sp1 = sd1 ; sp2 = sd2 ; sp3 = sd3
412 ep1 = ed1 ; ep2 = ed2 ; ep3 = ed3
413 SELECT CASE ( model_data_order )
414 CASE ( DATA_ORDER_XYZ )
415 sm1 = sp1 - bdx ; em1 = ep1 + bdx
416 sm2 = sp2 - bdy ; em2 = ep2 + bdy
417 sm3 = sp3 ; em3 = ep3
418 CASE ( DATA_ORDER_YXZ )
419 sm1 = sp1 - bdy ; em1 = ep1 + bdy
420 sm2 = sp2 - bdx ; em2 = ep2 + bdx
421 sm3 = sp3 ; em3 = ep3
422 CASE ( DATA_ORDER_ZXY )
423 sm1 = sp1 ; em1 = ep1
424 sm2 = sp2 - bdx ; em2 = ep2 + bdx
425 sm3 = sp3 - bdy ; em3 = ep3 + bdy
426 CASE ( DATA_ORDER_ZYX )
427 sm1 = sp1 ; em1 = ep1
428 sm2 = sp2 - bdy ; em2 = ep2 + bdy
429 sm3 = sp3 - bdx ; em3 = ep3 + bdx
430 CASE ( DATA_ORDER_XZY )
431 sm1 = sp1 - bdx ; em1 = ep1 + bdx
432 sm2 = sp2 ; em2 = ep2
433 sm3 = sp3 - bdy ; em3 = ep3 + bdy
434 CASE ( DATA_ORDER_YZX )
435 sm1 = sp1 - bdy ; em1 = ep1 + bdy
436 sm2 = sp2 ; em2 = ep2
437 sm3 = sp3 - bdx ; em3 = ep3 + bdx
439 sm1x = sm1 ; em1x = em1 ! just copy
440 sm2x = sm2 ; em2x = em2
441 sm3x = sm3 ; em3x = em3
442 sm1y = sm1 ; em1y = em1 ! just copy
443 sm2y = sm2 ; em2y = em2
444 sm3y = sm3 ; em3y = em3
445 ! assigns mostly just to suppress warning messages that INTENT OUT vars not assigned
446 sp1x = sp1 ; ep1x = ep1 ; sp2x = sp2 ; ep2x = ep2 ; sp3x = sp3 ; ep3x = ep3
447 sp1y = sp1 ; ep1y = ep1 ; sp2y = sp2 ; ep2y = ep2 ; sp3y = sp3 ; ep3y = ep3
450 ! This is supplied by the package specific version of module_dm, which
451 ! is supplied by the external package and copied into the src directory
452 ! when the code is compiled. The cp command will be found in the externals
453 ! target of the configure.wrf file for this architecture. Eg: for RSL
454 ! routine is defined in external/RSL/module_dm.F .
455 ! Note, it would be very nice to be able to pass parent to this routine;
456 ! however, there doesn't seem to be a way to do that in F90. That is because
457 ! to pass a pointer to a domain structure, this call requires an interface
458 ! definition for wrf_dm_patch_domain (otherwise it will try to convert the
459 ! pointer to something). In order to provide an interface definition, we
460 ! would need to either USE module_dm or use an interface block. In either
461 ! case it generates a circular USE reference, since module_dm uses
462 ! module_domain. JM 20020416
464 CALL wrf_dm_patch_domain( id , domdesc , parent_id , parent_domdesc , &
465 sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
466 sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
467 sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
468 sp1x , ep1x , sm1x , em1x , &
469 sp2x , ep2x , sm2x , em2x , &
470 sp3x , ep3x , sm3x , em3x , &
471 sp1y , ep1y , sm1y , em1y , &
472 sp2y , ep2y , sm2y , em2y , &
473 sp3y , ep3y , sm3y , em3y , &
476 SELECT CASE ( model_data_order )
477 CASE ( DATA_ORDER_XYZ )
478 bdy_mask( P_XSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
479 bdy_mask( P_YSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
480 bdy_mask( P_XEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
481 bdy_mask( P_YEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
482 CASE ( DATA_ORDER_YXZ )
483 bdy_mask( P_XSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
484 bdy_mask( P_YSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
485 bdy_mask( P_XEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
486 bdy_mask( P_YEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
487 CASE ( DATA_ORDER_ZXY )
488 bdy_mask( P_XSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
489 bdy_mask( P_YSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
490 bdy_mask( P_XEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
491 bdy_mask( P_YEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
492 CASE ( DATA_ORDER_ZYX )
493 bdy_mask( P_XSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
494 bdy_mask( P_YSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
495 bdy_mask( P_XEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
496 bdy_mask( P_YEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
497 CASE ( DATA_ORDER_XZY )
498 bdy_mask( P_XSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
499 bdy_mask( P_YSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
500 bdy_mask( P_XEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
501 bdy_mask( P_YEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
502 CASE ( DATA_ORDER_YZX )
503 bdy_mask( P_XSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
504 bdy_mask( P_YSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
505 bdy_mask( P_XEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
506 bdy_mask( P_YEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
512 END SUBROUTINE wrf_patch_domain
514 SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid )
517 ! This subroutine is used to allocate a domain data structure of
518 ! TYPE(DOMAIN) pointed to by the argument <em>grid</em>, link it into the
519 ! nested domain hierarchy, and set it's configuration information from
520 ! the appropriate settings in the WRF namelist file. Specifically, if the
521 ! domain being allocated and configured is nest, the <em>parent</em>
522 ! argument will point to the already existing domain data structure for
523 ! the parent domain and the <em>kid</em> argument will be set to an
524 ! integer indicating which child of the parent this grid will be (child
525 ! indices start at 1). If this is the top-level domain, the parent and
526 ! kid arguments are ignored. <b>WRF domains may have multiple children
527 ! but only ever have one parent.</b>
529 ! The <em>domain_id</em> argument is the
530 ! integer handle by which this new domain will be referred; it comes from
531 ! the grid_id setting in the namelist, and these grid ids correspond to
532 ! the ordering of settings in the namelist, starting with 1 for the
533 ! top-level domain. The id of 1 always corresponds to the top-level
534 ! domain. and these grid ids correspond to the ordering of settings in
535 ! the namelist, starting with 1 for the top-level domain.
537 ! Model_data_order is provide by USE association of
538 ! module_driver_constants and is set from dimspec entries in the
541 ! The allocation of the TYPE(DOMAIN) itself occurs in this routine.
542 ! However, the numerous multi-dimensional arrays that make up the members
543 ! of the domain are allocated in the call to alloc_space_field, after
544 ! wrf_patch_domain has been called to determine the dimensions in memory
545 ! that should be allocated. It bears noting here that arrays and code
546 ! that indexes these arrays are always global, regardless of how the
547 ! model is decomposed over patches. Thus, when arrays are allocated on a
548 ! given process, the start and end of an array dimension are the global
549 ! indices of the start and end of that process's subdomain.
551 ! Configuration information for the domain (that is, information from the
552 ! namelist) is added by the call to <a href=med_add_config_info_to_grid.html>med_add_config_info_to_grid</a>, defined
553 ! in share/mediation_wrfmain.F.
556 USE module_alloc_space
561 INTEGER , INTENT(IN) :: domain_id
562 TYPE( domain ) , POINTER :: grid
563 TYPE( domain ) , POINTER :: parent
564 INTEGER , INTENT(IN) :: kid ! which kid of parent am I?
567 INTEGER :: sd1 , ed1 , sp1 , ep1 , sm1 , em1
568 INTEGER :: sd2 , ed2 , sp2 , ep2 , sm2 , em2
569 INTEGER :: sd3 , ed3 , sp3 , ep3 , sm3 , em3
571 INTEGER :: sd1x , ed1x , sp1x , ep1x , sm1x , em1x
572 INTEGER :: sd2x , ed2x , sp2x , ep2x , sm2x , em2x
573 INTEGER :: sd3x , ed3x , sp3x , ep3x , sm3x , em3x
575 INTEGER :: sd1y , ed1y , sp1y , ep1y , sm1y , em1y
576 INTEGER :: sd2y , ed2y , sp2y , ep2y , sm2y , em2y
577 INTEGER :: sd3y , ed3y , sp3y , ep3y , sm3y , em3y
579 TYPE(domain) , POINTER :: new_grid
581 INTEGER :: parent_id , parent_domdesc , new_domdesc
582 INTEGER :: bdyzone_x , bdyzone_y
586 ! This next step uses information that is listed in the registry as namelist_derived
587 ! to properly size the domain and the patches; this in turn is stored in the new_grid
591 data_ordering : SELECT CASE ( model_data_order )
592 CASE ( DATA_ORDER_XYZ )
594 CALL nl_get_s_we( domain_id , sd1 )
595 CALL nl_get_e_we( domain_id , ed1 )
596 CALL nl_get_s_sn( domain_id , sd2 )
597 CALL nl_get_e_sn( domain_id , ed2 )
598 CALL nl_get_s_vert( domain_id , sd3 )
599 CALL nl_get_e_vert( domain_id , ed3 )
603 CASE ( DATA_ORDER_YXZ )
605 CALL nl_get_s_sn( domain_id , sd1 )
606 CALL nl_get_e_sn( domain_id , ed1 )
607 CALL nl_get_s_we( domain_id , sd2 )
608 CALL nl_get_e_we( domain_id , ed2 )
609 CALL nl_get_s_vert( domain_id , sd3 )
610 CALL nl_get_e_vert( domain_id , ed3 )
614 CASE ( DATA_ORDER_ZXY )
616 CALL nl_get_s_vert( domain_id , sd1 )
617 CALL nl_get_e_vert( domain_id , ed1 )
618 CALL nl_get_s_we( domain_id , sd2 )
619 CALL nl_get_e_we( domain_id , ed2 )
620 CALL nl_get_s_sn( domain_id , sd3 )
621 CALL nl_get_e_sn( domain_id , ed3 )
625 CASE ( DATA_ORDER_ZYX )
627 CALL nl_get_s_vert( domain_id , sd1 )
628 CALL nl_get_e_vert( domain_id , ed1 )
629 CALL nl_get_s_sn( domain_id , sd2 )
630 CALL nl_get_e_sn( domain_id , ed2 )
631 CALL nl_get_s_we( domain_id , sd3 )
632 CALL nl_get_e_we( domain_id , ed3 )
636 CASE ( DATA_ORDER_XZY )
638 CALL nl_get_s_we( domain_id , sd1 )
639 CALL nl_get_e_we( domain_id , ed1 )
640 CALL nl_get_s_vert( domain_id , sd2 )
641 CALL nl_get_e_vert( domain_id , ed2 )
642 CALL nl_get_s_sn( domain_id , sd3 )
643 CALL nl_get_e_sn( domain_id , ed3 )
647 CASE ( DATA_ORDER_YZX )
649 CALL nl_get_s_sn( domain_id , sd1 )
650 CALL nl_get_e_sn( domain_id , ed1 )
651 CALL nl_get_s_vert( domain_id , sd2 )
652 CALL nl_get_e_vert( domain_id , ed2 )
653 CALL nl_get_s_we( domain_id , sd3 )
654 CALL nl_get_e_we( domain_id , ed3 )
658 END SELECT data_ordering
660 IF ( num_time_levels > 3 ) THEN
661 WRITE ( wrf_err_message , * ) 'alloc_and_configure_domain: ', &
662 'Incorrect value for num_time_levels ', num_time_levels
663 CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
666 IF (ASSOCIATED(parent)) THEN
667 parent_id = parent%id
668 parent_domdesc = parent%domdesc
674 ! provided by application, WRF defines in share/module_bc.F
675 CALL get_bdyzone_x( bdyzone_x )
676 CALL get_bdyzone_y( bdyzone_y )
678 ALLOCATE ( new_grid )
679 ALLOCATE ( new_grid%parents( max_parents ) )
680 ALLOCATE ( new_grid%nests( max_nests ) )
681 NULLIFY( new_grid%sibling )
683 NULLIFY( new_grid%nests(i)%ptr )
685 NULLIFY (new_grid%next)
686 NULLIFY (new_grid%same_level)
687 NULLIFY (new_grid%i_start)
688 NULLIFY (new_grid%j_start)
689 NULLIFY (new_grid%i_end)
690 NULLIFY (new_grid%j_end)
691 ALLOCATE( new_grid%domain_clock )
692 new_grid%domain_clock_created = .FALSE.
693 ALLOCATE( new_grid%alarms( MAX_WRF_ALARMS ) ) ! initialize in setup_timekeeping
694 ALLOCATE( new_grid%alarms_created( MAX_WRF_ALARMS ) )
695 DO i = 1, MAX_WRF_ALARMS
696 new_grid%alarms_created( i ) = .FALSE.
698 new_grid%time_set = .FALSE.
700 ! set up the pointers that represent the nest hierarchy
701 ! set this up *prior* to calling the patching or allocation
702 ! routines so that implementations of these routines can
703 ! traverse the nest hierarchy (through the root head_grid)
707 IF ( domain_id .NE. 1 ) THEN
708 new_grid%parents(1)%ptr => parent
709 new_grid%num_parents = 1
710 parent%nests(kid)%ptr => new_grid
711 new_grid%child_of_parent(1) = kid ! note assumption that nest can have only 1 parent
712 parent%num_nests = parent%num_nests + 1
714 new_grid%id = domain_id ! this needs to be assigned prior to calling wrf_patch_domain
716 CALL wrf_patch_domain( domain_id , new_domdesc , parent, parent_id, parent_domdesc , &
718 sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & ! z-xpose dims
719 sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & ! (standard)
720 sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
722 sp1x , ep1x , sm1x , em1x , & ! x-xpose dims
723 sp2x , ep2x , sm2x , em2x , &
724 sp3x , ep3x , sm3x , em3x , &
726 sp1y , ep1y , sm1y , em1y , & ! y-xpose dims
727 sp2y , ep2y , sm2y , em2y , &
728 sp3y , ep3y , sm3y , em3y , &
730 bdyzone_x , bdyzone_y , new_grid%bdy_mask &
734 new_grid%domdesc = new_domdesc
735 new_grid%num_nests = 0
736 new_grid%num_siblings = 0
737 new_grid%num_parents = 0
738 new_grid%max_tiles = 0
739 new_grid%num_tiles_spec = 0
740 new_grid%nframes = 0 ! initialize the number of frames per file (array assignment)
742 CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. , &
743 sd1, ed1, sd2, ed2, sd3, ed3, &
744 sm1, em1, sm2, em2, sm3, em3, &
745 sm1x, em1x, sm2x, em2x, sm3x, em3x, & ! x-xpose
746 sm1y, em1y, sm2y, em2y, sm3y, em3y & ! y-xpose
749 !set these here, after alloc_space_field, which initializes vc_i, vc_j to zero
775 new_grid%sp31x = sp1x
776 new_grid%ep31x = ep1x
777 new_grid%sm31x = sm1x
778 new_grid%em31x = em1x
779 new_grid%sp32x = sp2x
780 new_grid%ep32x = ep2x
781 new_grid%sm32x = sm2x
782 new_grid%em32x = em2x
783 new_grid%sp33x = sp3x
784 new_grid%ep33x = ep3x
785 new_grid%sm33x = sm3x
786 new_grid%em33x = em3x
788 new_grid%sp31y = sp1y
789 new_grid%ep31y = ep1y
790 new_grid%sm31y = sm1y
791 new_grid%em31y = em1y
792 new_grid%sp32y = sp2y
793 new_grid%ep32y = ep2y
794 new_grid%sm32y = sm2y
795 new_grid%em32y = em2y
796 new_grid%sp33y = sp3y
797 new_grid%ep33y = ep3y
798 new_grid%sm33y = sm3y
799 new_grid%em33y = em3y
801 SELECT CASE ( model_data_order )
802 CASE ( DATA_ORDER_XYZ )
803 new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
804 new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
805 new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
806 new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
807 new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
808 new_grid%em21 = em1 ; new_grid%em22 = em2 ;
815 CASE ( DATA_ORDER_YXZ )
816 new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
817 new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
818 new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
819 new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
820 new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
821 new_grid%em21 = em1 ; new_grid%em22 = em2 ;
828 CASE ( DATA_ORDER_ZXY )
829 new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
830 new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
831 new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
832 new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
833 new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
834 new_grid%em21 = em2 ; new_grid%em22 = em3 ;
841 CASE ( DATA_ORDER_ZYX )
842 new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
843 new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
844 new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
845 new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
846 new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
847 new_grid%em21 = em2 ; new_grid%em22 = em3 ;
854 CASE ( DATA_ORDER_XZY )
855 new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
856 new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
857 new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
858 new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
859 new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
860 new_grid%em21 = em1 ; new_grid%em22 = em3 ;
867 CASE ( DATA_ORDER_YZX )
868 new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
869 new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
870 new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
871 new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
872 new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
873 new_grid%em21 = em1 ; new_grid%em22 = em3 ;
882 CALL med_add_config_info_to_grid ( new_grid ) ! this is a mediation layer routine
884 ! Some miscellaneous state that is in the Registry but not namelist data
886 new_grid%tiled = .false.
887 new_grid%patched = .false.
888 NULLIFY(new_grid%mapping)
890 ! This next set of includes causes all but the namelist_derived variables to be
891 ! properly assigned to the new_grid record
895 ! Allocate storage for time series metadata
896 ALLOCATE( grid%lattsloc( grid%max_ts_locs ) )
897 ALLOCATE( grid%lontsloc( grid%max_ts_locs ) )
898 ALLOCATE( grid%nametsloc( grid%max_ts_locs ) )
899 ALLOCATE( grid%desctsloc( grid%max_ts_locs ) )
900 ALLOCATE( grid%itsloc( grid%max_ts_locs ) )
901 ALLOCATE( grid%jtsloc( grid%max_ts_locs ) )
902 ALLOCATE( grid%id_tsloc( grid%max_ts_locs ) )
903 ALLOCATE( grid%ts_filename( grid%max_ts_locs ) )
905 grid%ntsloc_domain = 0
908 CALL wrf_get_dm_communicator ( grid%communicator )
909 CALL wrf_dm_define_comms( grid )
912 END SUBROUTINE alloc_and_configure_domain
916 ! This routine ALLOCATEs the required space for the meteorological fields
917 ! for a specific domain. The fields are simply ALLOCATEd as an -1. They
918 ! are referenced as wind, temperature, moisture, etc. in routines that are
919 ! below this top-level of data allocation and management (in the solve routine
922 SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , &
923 sd31, ed31, sd32, ed32, sd33, ed33, &
924 sm31 , em31 , sm32 , em32 , sm33 , em33 , &
925 sm31x, em31x, sm32x, em32x, sm33x, em33x, &
926 sm31y, em31y, sm32y, em32y, sm33y, em33y )
928 USE module_alloc_space, ONLY : alloc_space_field_core
933 TYPE(domain) , POINTER :: grid
934 INTEGER , INTENT(IN) :: id
935 INTEGER , INTENT(IN) :: setinitval_in ! 3 = everything, 1 = arrays only, 0 = none
936 INTEGER , INTENT(IN) :: sd31, ed31, sd32, ed32, sd33, ed33
937 INTEGER , INTENT(IN) :: sm31, em31, sm32, em32, sm33, em33
938 INTEGER , INTENT(IN) :: sm31x, em31x, sm32x, em32x, sm33x, em33x
939 INTEGER , INTENT(IN) :: sm31y, em31y, sm32y, em32y, sm33y, em33y
941 ! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.
942 ! e.g. to set both 1st and second time level, use 3
943 ! to set only 1st use 1
944 ! to set only 2st use 2
945 INTEGER , INTENT(IN) :: tl_in
947 ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated
948 ! false otherwise (all allocated, modulo tl above)
949 LOGICAL , INTENT(IN) :: inter_domain_in
951 ! now a separate module in WRFV3 to reduce the size of module_domain that the compiler sees
952 CALL alloc_space_field_core ( grid, id, setinitval_in , tl_in , inter_domain_in , &
953 sd31, ed31, sd32, ed32, sd33, ed33, &
954 sm31 , em31 , sm32 , em32 , sm33 , em33 , &
955 sm31x, em31x, sm32x, em32x, sm33x, em33x, &
956 sm31y, em31y, sm32y, em32y, sm33y, em33y )
958 END SUBROUTINE alloc_space_field
960 ! This routine is used to DEALLOCATE space for a single domain and remove
961 ! it from the linked list. First the pointers in the linked list are fixed
962 ! (so the one in the middle can be removed). Then the domain itself is
963 ! DEALLOCATEd via a call to domain_destroy().
965 SUBROUTINE dealloc_space_domain ( id )
971 INTEGER , INTENT(IN) :: id
975 TYPE(domain) , POINTER :: grid
978 ! Initializations required to start the routine.
981 old_grid => head_grid
984 ! The identity of the domain to delete is based upon the "id".
985 ! We search all of the possible grids. It is required to find a domain
986 ! otherwise it is a fatal error.
988 find_grid : DO WHILE ( ASSOCIATED(grid) )
989 IF ( grid%id == id ) THEN
991 old_grid%next => grid%next
992 CALL domain_destroy( grid )
999 IF ( .NOT. found ) THEN
1000 WRITE ( wrf_err_message , * ) 'module_domain: ', &
1001 'dealloc_space_domain: Could not de-allocate grid id ',id
1002 CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1005 END SUBROUTINE dealloc_space_domain
1009 ! This routine is used to DEALLOCATE space for a single domain type.
1010 ! First, the field data are all removed through a CALL to the
1011 ! dealloc_space_field routine. Then the pointer to the domain
1012 ! itself is DEALLOCATEd.
1014 SUBROUTINE domain_destroy ( grid )
1020 TYPE(domain) , POINTER :: grid
1022 CALL dealloc_space_field ( grid )
1023 DEALLOCATE( grid%parents )
1024 DEALLOCATE( grid%nests )
1025 ! clean up time manager bits
1026 CALL domain_clock_destroy( grid )
1027 CALL domain_alarms_destroy( grid )
1028 IF ( ASSOCIATED( grid%i_start ) ) THEN
1029 DEALLOCATE( grid%i_start )
1031 IF ( ASSOCIATED( grid%i_end ) ) THEN
1032 DEALLOCATE( grid%i_end )
1034 IF ( ASSOCIATED( grid%j_start ) ) THEN
1035 DEALLOCATE( grid%j_start )
1037 IF ( ASSOCIATED( grid%j_end ) ) THEN
1038 DEALLOCATE( grid%j_end )
1040 IF ( ASSOCIATED( grid%itsloc ) ) THEN
1041 DEALLOCATE( grid%itsloc )
1043 IF ( ASSOCIATED( grid%jtsloc ) ) THEN
1044 DEALLOCATE( grid%jtsloc )
1046 IF ( ASSOCIATED( grid%id_tsloc ) ) THEN
1047 DEALLOCATE( grid%id_tsloc )
1049 IF ( ASSOCIATED( grid%lattsloc ) ) THEN
1050 DEALLOCATE( grid%lattsloc )
1052 IF ( ASSOCIATED( grid%lontsloc ) ) THEN
1053 DEALLOCATE( grid%lontsloc )
1055 IF ( ASSOCIATED( grid%nametsloc ) ) THEN
1056 DEALLOCATE( grid%nametsloc )
1058 IF ( ASSOCIATED( grid%desctsloc ) ) THEN
1059 DEALLOCATE( grid%desctsloc )
1061 IF ( ASSOCIATED( grid%ts_filename ) ) THEN
1062 DEALLOCATE( grid%ts_filename )
1067 END SUBROUTINE domain_destroy
1069 RECURSIVE SUBROUTINE show_nest_subtree ( grid )
1070 TYPE(domain), POINTER :: grid
1073 IF ( .NOT. ASSOCIATED( grid ) ) RETURN
1075 write(0,*)'show_nest_subtree ',myid
1076 DO kid = 1, max_nests
1077 IF ( ASSOCIATED( grid%nests(kid)%ptr ) ) THEN
1078 IF ( grid%nests(kid)%ptr%id .EQ. myid ) THEN
1079 CALL wrf_error_fatal( 'show_nest_subtree: nest hierarchy corrupted' )
1081 CALL show_nest_subtree( grid%nests(kid)%ptr )
1084 END SUBROUTINE show_nest_subtree
1089 ! This routine DEALLOCATEs each gridded field for this domain. For each type of
1090 ! different array (1d, 2d, 3d, etc.), the space for each pointer is DEALLOCATEd
1091 ! for every -1 (i.e., each different meteorological field).
1093 SUBROUTINE dealloc_space_field ( grid )
1099 TYPE(domain) , POINTER :: grid
1105 # include <deallocs.inc>
1107 END SUBROUTINE dealloc_space_field
1111 RECURSIVE SUBROUTINE find_grid_by_id ( id, in_grid, result_grid )
1113 INTEGER, INTENT(IN) :: id
1114 TYPE(domain), POINTER :: in_grid
1115 TYPE(domain), POINTER :: result_grid
1117 ! This is a recursive subroutine that traverses the domain hierarchy rooted
1118 ! at the input argument <em>in_grid</em>, a pointer to TYPE(domain), and returns
1119 ! a pointer to the domain matching the integer argument <em>id</em> if it exists.
1122 TYPE(domain), POINTER :: grid_ptr
1126 IF ( ASSOCIATED( in_grid ) ) THEN
1127 IF ( in_grid%id .EQ. id ) THEN
1128 result_grid => in_grid
1131 DO WHILE ( ASSOCIATED( grid_ptr ) .AND. .NOT. found )
1132 DO kid = 1, max_nests
1133 IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) .AND. .NOT. found ) THEN
1134 CALL find_grid_by_id ( id, grid_ptr%nests(kid)%ptr, result_grid )
1135 IF ( ASSOCIATED( result_grid ) ) THEN
1136 IF ( result_grid%id .EQ. id ) found = .TRUE.
1140 IF ( .NOT. found ) grid_ptr => grid_ptr%sibling
1145 END SUBROUTINE find_grid_by_id
1148 FUNCTION first_loc_integer ( array , search ) RESULT ( loc )
1154 INTEGER , INTENT(IN) , DIMENSION(:) :: array
1155 INTEGER , INTENT(IN) :: search
1162 ! This routine is used to find a specific domain identifier in an array
1163 ! of domain identifiers.
1172 find : DO loop = 1 , SIZE(array)
1173 IF ( search == array(loop) ) THEN
1179 END FUNCTION first_loc_integer
1181 SUBROUTINE init_module_domain
1182 END SUBROUTINE init_module_domain
1187 ! The following routines named domain_*() are convenience routines that
1188 ! eliminate many duplicated bits of code. They provide shortcuts for the
1189 ! most common operations on the domain_clock field of TYPE(domain).
1193 FUNCTION domain_get_current_time ( grid ) RESULT ( current_time )
1196 ! This convenience function returns the current time for domain grid.
1199 TYPE(domain), INTENT(IN) :: grid
1201 TYPE(WRFU_Time) :: current_time
1204 CALL WRFU_ClockGet( grid%domain_clock, CurrTime=current_time, &
1206 IF ( rc /= WRFU_SUCCESS ) THEN
1207 CALL wrf_error_fatal ( &
1208 'domain_get_current_time: WRFU_ClockGet failed' )
1210 END FUNCTION domain_get_current_time
1213 FUNCTION domain_get_start_time ( grid ) RESULT ( start_time )
1216 ! This convenience function returns the start time for domain grid.
1219 TYPE(domain), INTENT(IN) :: grid
1221 TYPE(WRFU_Time) :: start_time
1224 CALL WRFU_ClockGet( grid%domain_clock, StartTime=start_time, &
1226 IF ( rc /= WRFU_SUCCESS ) THEN
1227 CALL wrf_error_fatal ( &
1228 'domain_get_start_time: WRFU_ClockGet failed' )
1230 END FUNCTION domain_get_start_time
1233 FUNCTION domain_get_stop_time ( grid ) RESULT ( stop_time )
1236 ! This convenience function returns the stop time for domain grid.
1239 TYPE(domain), INTENT(IN) :: grid
1241 TYPE(WRFU_Time) :: stop_time
1244 CALL WRFU_ClockGet( grid%domain_clock, StopTime=stop_time, &
1246 IF ( rc /= WRFU_SUCCESS ) THEN
1247 CALL wrf_error_fatal ( &
1248 'domain_get_stop_time: WRFU_ClockGet failed' )
1250 END FUNCTION domain_get_stop_time
1253 FUNCTION domain_get_time_step ( grid ) RESULT ( time_step )
1256 ! This convenience function returns the time step for domain grid.
1259 TYPE(domain), INTENT(IN) :: grid
1261 TYPE(WRFU_TimeInterval) :: time_step
1264 CALL WRFU_ClockGet( grid%domain_clock, timeStep=time_step, &
1266 IF ( rc /= WRFU_SUCCESS ) THEN
1267 CALL wrf_error_fatal ( &
1268 'domain_get_time_step: WRFU_ClockGet failed' )
1270 END FUNCTION domain_get_time_step
1273 FUNCTION domain_get_advanceCount ( grid ) RESULT ( advanceCount )
1276 ! This convenience function returns the time step for domain grid.
1277 ! Also converts from INTEGER(WRFU_KIND_I8) to INTEGER.
1280 TYPE(domain), INTENT(IN) :: grid
1282 INTEGER :: advanceCount
1284 INTEGER(WRFU_KIND_I8) :: advanceCountLcl
1286 CALL WRFU_ClockGet( grid%domain_clock, &
1287 advanceCount=advanceCountLcl, &
1289 IF ( rc /= WRFU_SUCCESS ) THEN
1290 CALL wrf_error_fatal ( &
1291 'domain_get_advanceCount: WRFU_ClockGet failed' )
1293 advanceCount = advanceCountLcl
1294 END FUNCTION domain_get_advanceCount
1297 SUBROUTINE domain_alarms_destroy ( grid )
1300 ! This convenience routine destroys and deallocates all alarms associated
1304 TYPE(domain), INTENT(INOUT) :: grid
1308 IF ( ASSOCIATED( grid%alarms ) .AND. &
1309 ASSOCIATED( grid%alarms_created ) ) THEN
1310 DO alarmid = 1, MAX_WRF_ALARMS
1311 IF ( grid%alarms_created( alarmid ) ) THEN
1312 CALL WRFU_AlarmDestroy( grid%alarms( alarmid ) )
1313 grid%alarms_created( alarmid ) = .FALSE.
1316 DEALLOCATE( grid%alarms )
1317 NULLIFY( grid%alarms )
1318 DEALLOCATE( grid%alarms_created )
1319 NULLIFY( grid%alarms_created )
1321 END SUBROUTINE domain_alarms_destroy
1324 SUBROUTINE domain_clock_destroy ( grid )
1327 ! This convenience routine destroys and deallocates the domain clock.
1330 TYPE(domain), INTENT(INOUT) :: grid
1331 IF ( ASSOCIATED( grid%domain_clock ) ) THEN
1332 IF ( grid%domain_clock_created ) THEN
1333 CALL WRFU_ClockDestroy( grid%domain_clock )
1334 grid%domain_clock_created = .FALSE.
1336 DEALLOCATE( grid%domain_clock )
1337 NULLIFY( grid%domain_clock )
1339 END SUBROUTINE domain_clock_destroy
1342 FUNCTION domain_last_time_step ( grid ) RESULT ( LAST_TIME )
1345 ! This convenience function returns .TRUE. if this is the last time
1346 ! step for domain grid. Thanks to Tom Black.
1349 TYPE(domain), INTENT(IN) :: grid
1351 LOGICAL :: LAST_TIME
1352 LAST_TIME = domain_get_stop_time( grid ) .EQ. &
1353 ( domain_get_current_time( grid ) + &
1354 domain_get_time_step( grid ) )
1355 END FUNCTION domain_last_time_step
1359 FUNCTION domain_clockisstoptime ( grid ) RESULT ( is_stop_time )
1362 ! This convenience function returns .TRUE. iff grid%clock has reached its
1366 TYPE(domain), INTENT(IN) :: grid
1368 LOGICAL :: is_stop_time
1370 is_stop_time = WRFU_ClockIsStopTime( grid%domain_clock , rc=rc )
1371 IF ( rc /= WRFU_SUCCESS ) THEN
1372 CALL wrf_error_fatal ( &
1373 'domain_clockisstoptime: WRFU_ClockIsStopTime() failed' )
1375 END FUNCTION domain_clockisstoptime
1379 FUNCTION domain_clockisstopsubtime ( grid ) RESULT ( is_stop_subtime )
1382 ! This convenience function returns .TRUE. iff grid%clock has reached its
1383 ! grid%stop_subtime.
1386 TYPE(domain), INTENT(IN) :: grid
1388 LOGICAL :: is_stop_subtime
1390 TYPE(WRFU_TimeInterval) :: timeStep
1391 TYPE(WRFU_Time) :: currentTime
1392 LOGICAL :: positive_timestep
1393 is_stop_subtime = .FALSE.
1394 CALL domain_clock_get( grid, time_step=timeStep, &
1395 current_time=currentTime )
1396 positive_timestep = ESMF_TimeIntervalIsPositive( timeStep )
1397 IF ( positive_timestep ) THEN
1398 ! hack for bug in PGI 5.1-x
1399 ! IF ( currentTime .GE. grid%stop_subtime ) THEN
1400 IF ( ESMF_TimeGE( currentTime, grid%stop_subtime ) ) THEN
1401 is_stop_subtime = .TRUE.
1404 ! hack for bug in PGI 5.1-x
1405 ! IF ( currentTime .LE. grid%stop_subtime ) THEN
1406 IF ( ESMF_TimeLE( currentTime, grid%stop_subtime ) ) THEN
1407 is_stop_subtime = .TRUE.
1410 END FUNCTION domain_clockisstopsubtime
1415 FUNCTION domain_get_sim_start_time ( grid ) RESULT ( simulationStartTime )
1418 ! This convenience routine returns simulation start time for domain grid as
1421 ! If this is not a restart run, the start_time of head_grid%clock is returned
1424 ! Note that simulation start time remains constant through restarts while
1425 ! the start_time of head_grid%clock always refers to the start time of the
1426 ! current run (restart or otherwise).
1429 TYPE(domain), INTENT(IN) :: grid
1431 TYPE(WRFU_Time) :: simulationStartTime
1434 INTEGER :: simulation_start_year, simulation_start_month, &
1435 simulation_start_day, simulation_start_hour , &
1436 simulation_start_minute, simulation_start_second
1437 CALL nl_get_simulation_start_year ( 1, simulation_start_year )
1438 CALL nl_get_simulation_start_month ( 1, simulation_start_month )
1439 CALL nl_get_simulation_start_day ( 1, simulation_start_day )
1440 CALL nl_get_simulation_start_hour ( 1, simulation_start_hour )
1441 CALL nl_get_simulation_start_minute ( 1, simulation_start_minute )
1442 CALL nl_get_simulation_start_second ( 1, simulation_start_second )
1443 CALL WRFU_TimeSet( simulationStartTime, &
1444 YY=simulation_start_year, &
1445 MM=simulation_start_month, &
1446 DD=simulation_start_day, &
1447 H=simulation_start_hour, &
1448 M=simulation_start_minute, &
1449 S=simulation_start_second, &
1451 IF ( rc /= WRFU_SUCCESS ) THEN
1452 CALL nl_get_start_year ( 1, simulation_start_year )
1453 CALL nl_get_start_month ( 1, simulation_start_month )
1454 CALL nl_get_start_day ( 1, simulation_start_day )
1455 CALL nl_get_start_hour ( 1, simulation_start_hour )
1456 CALL nl_get_start_minute ( 1, simulation_start_minute )
1457 CALL nl_get_start_second ( 1, simulation_start_second )
1458 CALL wrf_debug( 150, "WARNING: domain_get_sim_start_time using head_grid start time from namelist" )
1459 CALL WRFU_TimeSet( simulationStartTime, &
1460 YY=simulation_start_year, &
1461 MM=simulation_start_month, &
1462 DD=simulation_start_day, &
1463 H=simulation_start_hour, &
1464 M=simulation_start_minute, &
1465 S=simulation_start_second, &
1469 END FUNCTION domain_get_sim_start_time
1471 FUNCTION domain_get_time_since_sim_start ( grid ) RESULT ( time_since_sim_start )
1474 ! This convenience function returns the time elapsed since start of
1475 ! simulation for domain grid.
1477 ! Note that simulation start time remains constant through restarts while
1478 ! the start_time of grid%clock always refers to the start time of the
1479 ! current run (restart or otherwise).
1482 TYPE(domain), INTENT(IN) :: grid
1484 TYPE(WRFU_TimeInterval) :: time_since_sim_start
1486 TYPE(WRFU_Time) :: lcl_currtime, lcl_simstarttime
1487 lcl_simstarttime = domain_get_sim_start_time( grid )
1488 lcl_currtime = domain_get_current_time ( grid )
1489 time_since_sim_start = lcl_currtime - lcl_simstarttime
1490 END FUNCTION domain_get_time_since_sim_start
1495 SUBROUTINE domain_clock_get( grid, current_time, &
1497 current_timestr_frac, &
1498 start_time, start_timestr, &
1499 stop_time, stop_timestr, &
1500 time_step, time_stepstr, &
1501 time_stepstr_frac, &
1503 currentDayOfYearReal, &
1504 minutesSinceSimulationStart, &
1505 timeSinceSimulationStart, &
1506 simulationStartTime, &
1507 simulationStartTimeStr )
1509 TYPE(domain), INTENT(IN) :: grid
1510 TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: current_time
1511 CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: current_timestr
1512 CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: current_timestr_frac
1513 TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: start_time
1514 CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: start_timestr
1515 TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: stop_time
1516 CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: stop_timestr
1517 TYPE(WRFU_TimeInterval), INTENT( OUT), OPTIONAL :: time_step
1518 CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: time_stepstr
1519 CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: time_stepstr_frac
1520 INTEGER, INTENT( OUT), OPTIONAL :: advanceCount
1521 ! currentDayOfYearReal = 0.0 at 0Z on 1 January, 0.5 at 12Z on
1523 REAL, INTENT( OUT), OPTIONAL :: currentDayOfYearReal
1524 ! Time at which simulation started. If this is not a restart run,
1525 ! start_time is returned instead.
1526 TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: simulationStartTime
1527 CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: simulationStartTimeStr
1528 ! time interval since start of simulation, includes effects of
1529 ! restarting even when restart uses a different timestep
1530 TYPE(WRFU_TimeInterval), INTENT( OUT), OPTIONAL :: timeSinceSimulationStart
1531 ! minutes since simulation start date
1532 REAL, INTENT( OUT), OPTIONAL :: minutesSinceSimulationStart
1534 ! This convenience routine returns clock information for domain grid in
1535 ! various forms. The caller is responsible for ensuring that character
1536 ! string actual arguments are big enough.
1540 TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime, lcl_starttime
1541 TYPE(WRFU_Time) :: lcl_simulationStartTime
1542 TYPE(WRFU_TimeInterval) :: lcl_time_step, lcl_timeSinceSimulationStart
1543 INTEGER :: days, seconds, Sn, Sd, rc
1544 CHARACTER (LEN=256) :: tmp_str
1545 CHARACTER (LEN=256) :: frac_str
1546 REAL(WRFU_KIND_R8) :: currentDayOfYearR8
1547 IF ( PRESENT( start_time ) ) THEN
1548 start_time = domain_get_start_time ( grid )
1550 IF ( PRESENT( start_timestr ) ) THEN
1551 lcl_starttime = domain_get_start_time ( grid )
1552 CALL wrf_timetoa ( lcl_starttime, start_timestr )
1554 IF ( PRESENT( time_step ) ) THEN
1555 time_step = domain_get_time_step ( grid )
1557 IF ( PRESENT( time_stepstr ) ) THEN
1558 lcl_time_step = domain_get_time_step ( grid )
1559 CALL WRFU_TimeIntervalGet( lcl_time_step, &
1560 timeString=time_stepstr, rc=rc )
1561 IF ( rc /= WRFU_SUCCESS ) THEN
1562 CALL wrf_error_fatal ( &
1563 'domain_clock_get: WRFU_TimeIntervalGet() failed' )
1566 IF ( PRESENT( time_stepstr_frac ) ) THEN
1567 lcl_time_step = domain_get_time_step ( grid )
1568 CALL WRFU_TimeIntervalGet( lcl_time_step, timeString=tmp_str, &
1569 Sn=Sn, Sd=Sd, rc=rc )
1570 IF ( rc /= WRFU_SUCCESS ) THEN
1571 CALL wrf_error_fatal ( &
1572 'domain_clock_get: WRFU_TimeIntervalGet() failed' )
1574 CALL fraction_to_string( Sn, Sd, frac_str )
1575 time_stepstr_frac = TRIM(tmp_str)//TRIM(frac_str)
1577 IF ( PRESENT( advanceCount ) ) THEN
1578 advanceCount = domain_get_advanceCount ( grid )
1580 ! This duplication avoids assignment of time-manager objects
1581 ! which works now in ESMF 2.2.0 but may not work in the future
1582 ! if these objects become "deep". We have already been bitten
1583 ! by this when the clock objects were changed from "shallow" to
1584 ! "deep". Once again, adherence to orthodox canonical form by
1585 ! ESMF would avoid all this crap.
1586 IF ( PRESENT( current_time ) ) THEN
1587 current_time = domain_get_current_time ( grid )
1589 IF ( PRESENT( current_timestr ) ) THEN
1590 lcl_currtime = domain_get_current_time ( grid )
1591 CALL wrf_timetoa ( lcl_currtime, current_timestr )
1593 ! current time string including fractional part, if present
1594 IF ( PRESENT( current_timestr_frac ) ) THEN
1595 lcl_currtime = domain_get_current_time ( grid )
1596 CALL wrf_timetoa ( lcl_currtime, tmp_str )
1597 CALL WRFU_TimeGet( lcl_currtime, Sn=Sn, Sd=Sd, rc=rc )
1598 IF ( rc /= WRFU_SUCCESS ) THEN
1599 CALL wrf_error_fatal ( &
1600 'domain_clock_get: WRFU_TimeGet() failed' )
1602 CALL fraction_to_string( Sn, Sd, frac_str )
1603 current_timestr_frac = TRIM(tmp_str)//TRIM(frac_str)
1605 IF ( PRESENT( stop_time ) ) THEN
1606 stop_time = domain_get_stop_time ( grid )
1608 IF ( PRESENT( stop_timestr ) ) THEN
1609 lcl_stoptime = domain_get_stop_time ( grid )
1610 CALL wrf_timetoa ( lcl_stoptime, stop_timestr )
1612 IF ( PRESENT( currentDayOfYearReal ) ) THEN
1613 lcl_currtime = domain_get_current_time ( grid )
1614 CALL WRFU_TimeGet( lcl_currtime, dayOfYear_r8=currentDayOfYearR8, &
1616 IF ( rc /= WRFU_SUCCESS ) THEN
1617 CALL wrf_error_fatal ( &
1618 'domain_clock_get: WRFU_TimeGet(dayOfYear_r8) failed' )
1620 currentDayOfYearReal = REAL( currentDayOfYearR8 ) - 1.0
1622 IF ( PRESENT( simulationStartTime ) ) THEN
1623 simulationStartTime = domain_get_sim_start_time( grid )
1625 IF ( PRESENT( simulationStartTimeStr ) ) THEN
1626 lcl_simulationStartTime = domain_get_sim_start_time( grid )
1627 CALL wrf_timetoa ( lcl_simulationStartTime, simulationStartTimeStr )
1629 IF ( PRESENT( timeSinceSimulationStart ) ) THEN
1630 timeSinceSimulationStart = domain_get_time_since_sim_start( grid )
1632 IF ( PRESENT( minutesSinceSimulationStart ) ) THEN
1633 lcl_timeSinceSimulationStart = domain_get_time_since_sim_start( grid )
1634 CALL WRFU_TimeIntervalGet( lcl_timeSinceSimulationStart, &
1635 D=days, S=seconds, Sn=Sn, Sd=Sd, rc=rc )
1636 IF ( rc /= WRFU_SUCCESS ) THEN
1637 CALL wrf_error_fatal ( &
1638 'domain_clock_get: WRFU_TimeIntervalGet() failed' )
1640 ! get rid of hard-coded constants
1641 minutesSinceSimulationStart = ( REAL( days ) * 24. * 60. ) + &
1642 ( REAL( seconds ) / 60. )
1644 minutesSinceSimulationStart = minutesSinceSimulationStart + &
1645 ( ( REAL( Sn ) / REAL( Sd ) ) / 60. )
1649 END SUBROUTINE domain_clock_get
1651 FUNCTION domain_clockisstarttime ( grid ) RESULT ( is_start_time )
1654 ! This convenience function returns .TRUE. iff grid%clock is at its
1658 TYPE(domain), INTENT(IN) :: grid
1660 LOGICAL :: is_start_time
1661 TYPE(WRFU_Time) :: start_time, current_time
1662 CALL domain_clock_get( grid, current_time=current_time, &
1663 start_time=start_time )
1664 is_start_time = ( current_time == start_time )
1665 END FUNCTION domain_clockisstarttime
1667 FUNCTION domain_clockissimstarttime ( grid ) RESULT ( is_sim_start_time )
1670 ! This convenience function returns .TRUE. iff grid%clock is at the
1671 ! simulation start time. (It returns .FALSE. during a restart run.)
1674 TYPE(domain), INTENT(IN) :: grid
1676 LOGICAL :: is_sim_start_time
1677 TYPE(WRFU_Time) :: simulationStartTime, current_time
1678 CALL domain_clock_get( grid, current_time=current_time, &
1679 simulationStartTime=simulationStartTime )
1680 is_sim_start_time = ( current_time == simulationStartTime )
1681 END FUNCTION domain_clockissimstarttime
1686 SUBROUTINE domain_clock_create( grid, StartTime, &
1690 TYPE(domain), INTENT(INOUT) :: grid
1691 TYPE(WRFU_Time), INTENT(IN ) :: StartTime
1692 TYPE(WRFU_Time), INTENT(IN ) :: StopTime
1693 TYPE(WRFU_TimeInterval), INTENT(IN ) :: TimeStep
1695 ! This convenience routine creates the domain_clock for domain grid and
1696 ! sets associated flags.
1701 grid%domain_clock = WRFU_ClockCreate( TimeStep= TimeStep, &
1702 StartTime=StartTime, &
1703 StopTime= StopTime, &
1705 IF ( rc /= WRFU_SUCCESS ) THEN
1706 CALL wrf_error_fatal ( &
1707 'domain_clock_create: WRFU_ClockCreate() failed' )
1709 grid%domain_clock_created = .TRUE.
1711 END SUBROUTINE domain_clock_create
1715 SUBROUTINE domain_alarm_create( grid, alarm_id, interval, &
1716 begin_time, end_time )
1719 TYPE(domain), POINTER :: grid
1720 INTEGER, INTENT(IN) :: alarm_id
1721 TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: interval
1722 TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: begin_time
1723 TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: end_time
1725 ! This convenience routine creates alarm alarm_id for domain grid and
1726 ! sets associated flags.
1731 !$$$ TBH: Ideally, this could be simplified by passing all optional actual
1732 !$$$ TBH: args into AlarmCreate. However, since operations are performed on
1733 !$$$ TBH: the actual args in-place in the calls, they must be present for the
1734 !$$$ TBH: operations themselves to be defined. Grrr...
1735 LOGICAL :: interval_only, all_args, no_args
1736 TYPE(WRFU_Time) :: startTime
1737 interval_only = .FALSE.
1740 IF ( ( .NOT. PRESENT( begin_time ) ) .AND. &
1741 ( .NOT. PRESENT( end_time ) ) .AND. &
1742 ( PRESENT( interval ) ) ) THEN
1743 interval_only = .TRUE.
1744 ELSE IF ( ( .NOT. PRESENT( begin_time ) ) .AND. &
1745 ( .NOT. PRESENT( end_time ) ) .AND. &
1746 ( .NOT. PRESENT( interval ) ) ) THEN
1748 ELSE IF ( ( PRESENT( begin_time ) ) .AND. &
1749 ( PRESENT( end_time ) ) .AND. &
1750 ( PRESENT( interval ) ) ) THEN
1753 CALL wrf_error_fatal ( &
1754 'ERROR in domain_alarm_create: bad argument list' )
1756 CALL domain_clock_get( grid, start_time=startTime )
1757 IF ( interval_only ) THEN
1758 grid%io_intervals( alarm_id ) = interval
1759 grid%alarms( alarm_id ) = &
1760 WRFU_AlarmCreate( clock=grid%domain_clock, &
1761 RingInterval=interval, &
1763 ELSE IF ( no_args ) THEN
1764 grid%alarms( alarm_id ) = &
1765 WRFU_AlarmCreate( clock=grid%domain_clock, &
1766 RingTime=startTime, &
1768 ELSE IF ( all_args ) THEN
1769 grid%io_intervals( alarm_id ) = interval
1770 grid%alarms( alarm_id ) = &
1771 WRFU_AlarmCreate( clock=grid%domain_clock, &
1772 RingTime=startTime + begin_time, &
1773 RingInterval=interval, &
1774 StopTime=startTime + end_time, &
1777 IF ( rc /= WRFU_SUCCESS ) THEN
1778 CALL wrf_error_fatal ( &
1779 'domain_alarm_create: WRFU_AlarmCreate() failed' )
1781 grid%alarms_created( alarm_id ) = .TRUE.
1782 END SUBROUTINE domain_alarm_create
1786 SUBROUTINE domain_clock_set( grid, current_timestr, &
1790 TYPE(domain), INTENT(INOUT) :: grid
1791 CHARACTER (LEN=*), INTENT(IN ), OPTIONAL :: current_timestr
1792 CHARACTER (LEN=*), INTENT(IN ), OPTIONAL :: stop_timestr
1793 INTEGER, INTENT(IN ), OPTIONAL :: time_step_seconds
1795 ! This convenience routine sets clock information for domain grid.
1796 ! The caller is responsible for ensuring that character string actual
1797 ! arguments are big enough.
1801 TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime
1802 TYPE(WRFU_TimeInterval) :: tmpTimeInterval
1804 IF ( PRESENT( current_timestr ) ) THEN
1805 CALL wrf_atotime( current_timestr(1:19), lcl_currtime )
1806 CALL WRFU_ClockSet( grid%domain_clock, currTime=lcl_currtime, &
1808 IF ( rc /= WRFU_SUCCESS ) THEN
1809 CALL wrf_error_fatal ( &
1810 'domain_clock_set: WRFU_ClockSet(CurrTime) failed' )
1813 IF ( PRESENT( stop_timestr ) ) THEN
1814 CALL wrf_atotime( stop_timestr(1:19), lcl_stoptime )
1815 CALL WRFU_ClockSet( grid%domain_clock, stopTime=lcl_stoptime, &
1817 IF ( rc /= WRFU_SUCCESS ) THEN
1818 CALL wrf_error_fatal ( &
1819 'domain_clock_set: WRFU_ClockSet(StopTime) failed' )
1822 IF ( PRESENT( time_step_seconds ) ) THEN
1823 CALL WRFU_TimeIntervalSet( tmpTimeInterval, &
1824 S=time_step_seconds, rc=rc )
1825 IF ( rc /= WRFU_SUCCESS ) THEN
1826 CALL wrf_error_fatal ( &
1827 'domain_clock_set: WRFU_TimeIntervalSet failed' )
1829 CALL WRFU_ClockSet ( grid%domain_clock, &
1830 timeStep=tmpTimeInterval, &
1832 IF ( rc /= WRFU_SUCCESS ) THEN
1833 CALL wrf_error_fatal ( &
1834 'domain_clock_set: WRFU_ClockSet(TimeStep) failed' )
1838 END SUBROUTINE domain_clock_set
1841 ! Debug routine to print key clock information.
1842 ! Printed lines include pre_str.
1843 SUBROUTINE domain_clockprint ( level, grid, pre_str )
1845 INTEGER, INTENT( IN) :: level
1846 TYPE(domain), INTENT( IN) :: grid
1847 CHARACTER (LEN=*), INTENT( IN) :: pre_str
1848 CALL wrf_clockprint ( level, grid%domain_clock, pre_str )
1850 END SUBROUTINE domain_clockprint
1853 ! Advance the clock associated with grid.
1854 ! Also updates several derived time quantities in grid state.
1855 SUBROUTINE domain_clockadvance ( grid )
1857 TYPE(domain), INTENT(INOUT) :: grid
1859 CALL domain_clockprint ( 250, grid, &
1860 'DEBUG domain_clockadvance(): before WRFU_ClockAdvance,' )
1861 CALL WRFU_ClockAdvance( grid%domain_clock, rc=rc )
1862 IF ( rc /= WRFU_SUCCESS ) THEN
1863 CALL wrf_error_fatal ( &
1864 'domain_clockadvance: WRFU_ClockAdvance() failed' )
1866 CALL domain_clockprint ( 250, grid, &
1867 'DEBUG domain_clockadvance(): after WRFU_ClockAdvance,' )
1868 ! Update derived time quantities in grid state.
1869 ! These are initialized in setup_timekeeping().
1870 CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime )
1871 CALL domain_clock_get( grid, currentDayOfYearReal=grid%julian )
1873 END SUBROUTINE domain_clockadvance
1877 ! Set grid%gmt, grid%julday, and grid%julyr from simulation-start-date.
1878 ! Set start_of_simulation to TRUE iff current_time == simulation_start_time
1879 SUBROUTINE domain_setgmtetc ( grid, start_of_simulation )
1881 TYPE (domain), INTENT(INOUT) :: grid
1882 LOGICAL, INTENT( OUT) :: start_of_simulation
1884 CHARACTER (LEN=132) :: message
1885 TYPE(WRFU_Time) :: simStartTime
1886 INTEGER :: hr, mn, sec, ms, rc
1887 CALL domain_clockprint(150, grid, &
1888 'DEBUG domain_setgmtetc(): get simStartTime from clock,')
1889 CALL domain_clock_get( grid, simulationStartTime=simStartTime, &
1890 simulationStartTimeStr=message )
1891 CALL WRFU_TimeGet( simStartTime, YY=grid%julyr, dayOfYear=grid%julday, &
1892 H=hr, M=mn, S=sec, MS=ms, rc=rc)
1893 IF ( rc /= WRFU_SUCCESS ) THEN
1894 CALL wrf_error_fatal ( &
1895 'domain_setgmtetc: WRFU_TimeGet() failed' )
1897 WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc(): simulation start time = [',TRIM( message ),']'
1898 CALL wrf_debug( 150, TRIM(wrf_err_message) )
1899 grid%gmt=hr+real(mn)/60.+real(sec)/3600.+real(ms)/(1000*3600)
1900 WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc(): julyr,hr,mn,sec,ms,julday = ', &
1901 grid%julyr,hr,mn,sec,ms,grid%julday
1902 CALL wrf_debug( 150, TRIM(wrf_err_message) )
1903 WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc(): gmt = ',grid%gmt
1904 CALL wrf_debug( 150, TRIM(wrf_err_message) )
1905 start_of_simulation = domain_ClockIsSimStartTime(grid)
1907 END SUBROUTINE domain_setgmtetc
1911 ! Set pointer to current grid.
1912 ! To begin with, current grid is not set.
1913 SUBROUTINE set_current_grid_ptr( grid_ptr )
1915 TYPE(domain), POINTER :: grid_ptr
1916 !PRINT *,'DEBUG: begin set_current_grid_ptr()'
1917 !IF ( ASSOCIATED( grid_ptr ) ) THEN
1918 ! PRINT *,'DEBUG: set_current_grid_ptr(): current_grid is associated'
1920 ! PRINT *,'DEBUG: set_current_grid_ptr(): current_grid is NOT associated'
1922 current_grid_set = .TRUE.
1923 current_grid => grid_ptr
1924 !PRINT *,'DEBUG: end set_current_grid_ptr()'
1925 END SUBROUTINE set_current_grid_ptr
1927 !******************************************************************************
1928 ! BEGIN TEST SECTION
1929 ! Code in the test section is used to test domain methods.
1930 ! This code should probably be moved elsewhere, eventually.
1931 !******************************************************************************
1933 ! Private utility routines for domain_time_test.
1934 SUBROUTINE domain_time_test_print ( pre_str, name_str, res_str )
1936 CHARACTER (LEN=*), INTENT(IN) :: pre_str
1937 CHARACTER (LEN=*), INTENT(IN) :: name_str
1938 CHARACTER (LEN=*), INTENT(IN) :: res_str
1939 CHARACTER (LEN=512) :: out_str
1941 FMT="('DOMAIN_TIME_TEST ',A,': ',A,' = ',A)") &
1942 TRIM(pre_str), TRIM(name_str), TRIM(res_str)
1943 CALL wrf_debug( 0, TRIM(out_str) )
1944 END SUBROUTINE domain_time_test_print
1946 ! Test adjust_io_timestr
1947 SUBROUTINE test_adjust_io_timestr( TI_h, TI_m, TI_s, &
1948 CT_yy, CT_mm, CT_dd, CT_h, CT_m, CT_s, &
1949 ST_yy, ST_mm, ST_dd, ST_h, ST_m, ST_s, &
1951 INTEGER, INTENT(IN) :: TI_H
1952 INTEGER, INTENT(IN) :: TI_M
1953 INTEGER, INTENT(IN) :: TI_S
1954 INTEGER, INTENT(IN) :: CT_YY
1955 INTEGER, INTENT(IN) :: CT_MM ! month
1956 INTEGER, INTENT(IN) :: CT_DD ! day of month
1957 INTEGER, INTENT(IN) :: CT_H
1958 INTEGER, INTENT(IN) :: CT_M
1959 INTEGER, INTENT(IN) :: CT_S
1960 INTEGER, INTENT(IN) :: ST_YY
1961 INTEGER, INTENT(IN) :: ST_MM ! month
1962 INTEGER, INTENT(IN) :: ST_DD ! day of month
1963 INTEGER, INTENT(IN) :: ST_H
1964 INTEGER, INTENT(IN) :: ST_M
1965 INTEGER, INTENT(IN) :: ST_S
1966 CHARACTER (LEN=*), INTENT(IN) :: res_str
1967 CHARACTER (LEN=*), INTENT(IN) :: testname
1969 TYPE(WRFU_TimeInterval) :: TI
1970 TYPE(WRFU_Time) :: CT, ST
1971 LOGICAL :: test_passed
1973 CHARACTER(LEN=WRFU_MAXSTR) :: TI_str, CT_str, ST_str, computed_str
1975 CALL WRFU_TimeIntervalSet( TI, H=TI_H, M=TI_M, S=TI_S, rc=rc )
1976 CALL wrf_check_error( WRFU_SUCCESS, rc, &
1977 'FAIL: '//TRIM(testname)//'WRFU_TimeIntervalSet() ', &
1980 CALL WRFU_TimeIntervalGet( TI, timeString=TI_str, rc=rc )
1981 CALL wrf_check_error( WRFU_SUCCESS, rc, &
1982 'FAIL: '//TRIM(testname)//'WRFU_TimeGet() ', &
1986 CALL WRFU_TimeSet( CT, YY=CT_YY, MM=CT_MM, DD=CT_DD , &
1987 H=CT_H, M=CT_M, S=CT_S, rc=rc )
1988 CALL wrf_check_error( WRFU_SUCCESS, rc, &
1989 'FAIL: '//TRIM(testname)//'WRFU_TimeSet() ', &
1992 CALL WRFU_TimeGet( CT, timeString=CT_str, rc=rc )
1993 CALL wrf_check_error( WRFU_SUCCESS, rc, &
1994 'FAIL: '//TRIM(testname)//'WRFU_TimeGet() ', &
1998 CALL WRFU_TimeSet( ST, YY=ST_YY, MM=ST_MM, DD=ST_DD , &
1999 H=ST_H, M=ST_M, S=ST_S, rc=rc )
2000 CALL wrf_check_error( WRFU_SUCCESS, rc, &
2001 'FAIL: '//TRIM(testname)//'WRFU_TimeSet() ', &
2004 CALL WRFU_TimeGet( ST, timeString=ST_str, rc=rc )
2005 CALL wrf_check_error( WRFU_SUCCESS, rc, &
2006 'FAIL: '//TRIM(testname)//'WRFU_TimeGet() ', &
2010 CALL adjust_io_timestr ( TI, CT, ST, computed_str )
2012 test_passed = .FALSE.
2013 IF ( LEN_TRIM(res_str) == LEN_TRIM(computed_str) ) THEN
2014 IF ( res_str(1:LEN_TRIM(res_str)) == computed_str(1:LEN_TRIM(computed_str)) ) THEN
2015 test_passed = .TRUE.
2019 IF ( test_passed ) THEN
2020 WRITE(*,FMT='(A)') 'PASS: '//TRIM(testname)
2022 WRITE(*,*) 'FAIL: ',TRIM(testname),': adjust_io_timestr(', &
2023 TRIM(TI_str),',',TRIM(CT_str),',',TRIM(ST_str),') expected <', &
2024 TRIM(res_str),'> but computed <',TRIM(computed_str),'>'
2026 END SUBROUTINE test_adjust_io_timestr
2028 ! Print lots of time-related information for testing and debugging.
2029 ! Printed lines include pre_str and special string DOMAIN_TIME_TEST
2030 ! suitable for grepping by test scripts.
2031 ! Returns immediately unless self_test_domain has been set to .true. in
2032 ! namelist /time_control/ .
2033 SUBROUTINE domain_time_test ( grid, pre_str )
2035 TYPE(domain), INTENT(IN) :: grid
2036 CHARACTER (LEN=*), INTENT(IN) :: pre_str
2038 LOGICAL, SAVE :: one_time_tests_done = .FALSE.
2039 REAL :: minutesSinceSimulationStart
2040 INTEGER :: advance_count, rc
2041 REAL :: currentDayOfYearReal
2042 TYPE(WRFU_TimeInterval) :: timeSinceSimulationStart
2043 TYPE(WRFU_Time) :: simulationStartTime
2044 CHARACTER (LEN=512) :: res_str
2045 LOGICAL :: self_test_domain
2047 ! NOTE: test_adjust_io_timestr() (see below) is a self-test that
2048 ! prints PASS/FAIL/ERROR messages in a standard format. All
2049 ! of the other tests should be strucutred the same way,
2052 CALL nl_get_self_test_domain( 1, self_test_domain )
2053 IF ( self_test_domain ) THEN
2054 CALL domain_clock_get( grid, advanceCount=advance_count )
2055 WRITE ( res_str, FMT="(I8.8)" ) advance_count
2056 CALL domain_time_test_print( pre_str, 'advanceCount', res_str )
2057 CALL domain_clock_get( grid, currentDayOfYearReal=currentDayOfYearReal )
2058 WRITE ( res_str, FMT='(F10.6)' ) currentDayOfYearReal
2059 CALL domain_time_test_print( pre_str, 'currentDayOfYearReal', res_str )
2060 CALL domain_clock_get( grid, minutesSinceSimulationStart=minutesSinceSimulationStart )
2061 WRITE ( res_str, FMT='(F10.6)' ) minutesSinceSimulationStart
2062 CALL domain_time_test_print( pre_str, 'minutesSinceSimulationStart', res_str )
2063 CALL domain_clock_get( grid, current_timestr=res_str )
2064 CALL domain_time_test_print( pre_str, 'current_timestr', res_str )
2065 CALL domain_clock_get( grid, current_timestr_frac=res_str )
2066 CALL domain_time_test_print( pre_str, 'current_timestr_frac', res_str )
2067 CALL domain_clock_get( grid, timeSinceSimulationStart=timeSinceSimulationStart )
2068 CALL WRFU_TimeIntervalGet( timeSinceSimulationStart, timeString=res_str, rc=rc )
2069 IF ( rc /= WRFU_SUCCESS ) THEN
2070 CALL wrf_error_fatal ( &
2071 'domain_time_test: WRFU_TimeIntervalGet() failed' )
2073 CALL domain_time_test_print( pre_str, 'timeSinceSimulationStart', res_str )
2074 ! The following tests should only be done once, the first time this
2075 ! routine is called.
2076 IF ( .NOT. one_time_tests_done ) THEN
2077 one_time_tests_done = .TRUE.
2078 CALL domain_clock_get( grid, simulationStartTimeStr=res_str )
2079 CALL domain_time_test_print( pre_str, 'simulationStartTime', res_str )
2080 CALL domain_clock_get( grid, start_timestr=res_str )
2081 CALL domain_time_test_print( pre_str, 'start_timestr', res_str )
2082 CALL domain_clock_get( grid, stop_timestr=res_str )
2083 CALL domain_time_test_print( pre_str, 'stop_timestr', res_str )
2084 CALL domain_clock_get( grid, time_stepstr=res_str )
2085 CALL domain_time_test_print( pre_str, 'time_stepstr', res_str )
2086 CALL domain_clock_get( grid, time_stepstr_frac=res_str )
2087 CALL domain_time_test_print( pre_str, 'time_stepstr_frac', res_str )
2088 ! Test adjust_io_timestr()
2089 ! CT = 2000-01-26_00:00:00 (current time)
2090 ! ST = 2000-01-24_12:00:00 (start time)
2091 ! TI = 00000_03:00:00 (time interval)
2092 ! the resulting time string should be:
2093 ! 2000-01-26_00:00:00
2094 CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0, &
2095 CT_yy=2000, CT_mm=1, CT_dd=26, CT_h=0, CT_m=0, CT_s=0, &
2096 ST_yy=2000, ST_mm=1, ST_dd=24, ST_h=12, ST_m=0, ST_s=0, &
2097 res_str='2000-01-26_00:00:00', testname='adjust_io_timestr_1' )
2098 ! this should fail (and does)
2099 ! CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0, &
2100 ! CT_yy=2000, CT_mm=1, CT_dd=26, CT_h=0, CT_m=0, CT_s=0, &
2101 ! ST_yy=2000, ST_mm=1, ST_dd=24, ST_h=12, ST_m=0, ST_s=0, &
2102 ! res_str='2000-01-26_00:00:01', testname='adjust_io_timestr_FAIL1' )
2106 END SUBROUTINE domain_time_test
2108 !******************************************************************************
2110 !******************************************************************************
2113 END MODULE module_domain
2116 ! The following routines are outside this module to avoid build dependences.
2119 ! Get current time as a string (current time from clock attached to the
2120 ! current_grid). Includes fractional part, if present.
2121 ! Returns empty string if current_grid is not set or if timing has not yet
2122 ! been set up on current_grid.
2123 SUBROUTINE get_current_time_string( time_str )
2126 CHARACTER (LEN=*), INTENT(OUT) :: time_str
2128 INTEGER :: debug_level_lcl
2129 !PRINT *,'DEBUG: begin get_current_time_string()'
2131 IF ( current_grid_set ) THEN
2133 !PRINT *,'DEBUG: get_current_time_string(): checking association of current_grid...'
2134 !IF ( ASSOCIATED( current_grid ) ) THEN
2135 ! PRINT *,'DEBUG: get_current_time_string(): current_grid is associated'
2137 ! PRINT *,'DEBUG: get_current_time_string(): current_grid is NOT associated'
2140 IF ( current_grid%time_set ) THEN
2141 !PRINT *,'DEBUG: get_current_time_string(): calling domain_clock_get()'
2142 ! set debug_level to zero and clear current_grid_set to avoid recursion
2143 CALL get_wrf_debug_level( debug_level_lcl )
2144 CALL set_wrf_debug_level ( 0 )
2145 current_grid_set = .FALSE.
2146 CALL domain_clock_get( current_grid, current_timestr_frac=time_str )
2147 ! restore debug_level and current_grid_set
2148 CALL set_wrf_debug_level ( debug_level_lcl )
2149 current_grid_set = .TRUE.
2150 !PRINT *,'DEBUG: get_current_time_string(): back from domain_clock_get()'
2153 !PRINT *,'DEBUG: end get_current_time_string()'
2154 END SUBROUTINE get_current_time_string
2157 ! Get current domain name as a string of form "d<NN>" where "<NN>" is
2158 ! grid%id printed in two characters, with leading zero if needed ("d01",
2160 ! Return empty string if current_grid not set.
2161 SUBROUTINE get_current_grid_name( grid_str )
2164 CHARACTER (LEN=*), INTENT(OUT) :: grid_str
2166 IF ( current_grid_set ) THEN
2167 WRITE(grid_str,FMT="('d',I2.2)") current_grid%id
2169 END SUBROUTINE get_current_grid_name