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