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