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