Context Navigation

module_domain.F.v3.6.1

Last change on this file was 589, checked in by lfita, 10 years ago
Adding modification for version 3.6.1
File size: 139.0 KB

Line
1	!WRF:DRIVER_LAYER:DOMAIN_OBJECT
2	!
3	! Following are the routines contained within this MODULE:
4
5	! alloc_and_configure_domain 1. Allocate the space for a single domain (constants
6	! and null terminate pointers).
7	! 2. Connect the domains as a linked list.
8	! 3. Store all of the domain constants.
9	! 4. CALL alloc_space_field.
10
11	! alloc_space_field 1. Allocate space for the gridded data required for
12	! each domain.
13
14	! dealloc_space_domain 1. Reconnect linked list nodes since the current
15	! node is removed.
16	! 2. CALL dealloc_space_field.
17	! 3. Deallocate single domain.
18
19	! dealloc_space_field 1. Deallocate each of the fields for a particular
20	! domain.
21
22	! first_loc_integer 1. Find the first incidence of a particular
23	! domain identifier from an array of domain
24	! identifiers.
25
26	MODULE module_domain
27
28	USE module_driver_constants
29	USE module_machine
30	USE module_configure
31	USE module_wrf_error
32	USE module_utility
33	USE module_domain_type
34
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
39
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.
45
46	TYPE(domain) , POINTER :: head_grid , new_grid , next_grid , old_grid
47
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.
52
53	TYPE domain_levels
54	TYPE(domain) , POINTER :: first_domain
55	END TYPE domain_levels
56
57	TYPE(domain_levels) , DIMENSION(max_levels) :: head_for_each_level
58
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.
62
63	! internal routines
64	PRIVATE domain_time_test_print
65	PRIVATE test_adjust_io_timestr
66
67	INTERFACE get_ijk_from_grid
68	MODULE PROCEDURE get_ijk_from_grid1, get_ijk_from_grid2
69	END INTERFACE
70
71	INTEGER, PARAMETER :: max_hst_mods = 200
72
73	CONTAINS
74
75	SUBROUTINE adjust_domain_dims_for_move( grid , dx, dy )
76	IMPLICIT NONE
77
78	TYPE( domain ), POINTER :: grid
79	INTEGER, INTENT(IN) :: dx, dy
80
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
95
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
109
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
123
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
137
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
151
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
165
166	END SELECT data_ordering
167
168	#if 0
169	CALL dealloc_space_field ( grid )
170
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
181
182	RETURN
183	END SUBROUTINE adjust_domain_dims_for_move
184
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
204
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
242
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 )
247
248	IMPLICIT NONE
249
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
255
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
283
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
311
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
318
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
328
329
330	! Default version ; Otherwise module containing interface to DM library will provide
331
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>
390
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
404
405	!local data
406
407	INTEGER spec_bdy_width
408
409	CALL nl_get_spec_bdy_width( 1, spec_bdy_width )
410
411	#ifndef DM_PARALLEL
412
413	bdy_mask = .true. ! only one processor so all 4 boundaries are there
414
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
454
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
469
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 )
481
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
514
515	#endif
516
517	RETURN
518	END SUBROUTINE wrf_patch_domain
519	!
520	SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid )
521
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>
561
562	IMPLICIT NONE
563
564	! Input data.
565
566	INTEGER , INTENT(IN) :: domain_id
567	TYPE( domain ) , POINTER :: grid
568	TYPE( domain ) , POINTER :: parent
569	INTEGER , INTENT(IN) :: kid ! which kid of parent am I?
570
571	! Local data.
572	INTEGER :: sd1 , ed1 , sp1 , ep1 , sm1 , em1
573	INTEGER :: sd2 , ed2 , sp2 , ep2 , sm2 , em2
574	INTEGER :: sd3 , ed3 , sp3 , ep3 , sm3 , em3
575
576	INTEGER :: sd1x , ed1x , sp1x , ep1x , sm1x , em1x
577	INTEGER :: sd2x , ed2x , sp2x , ep2x , sm2x , em2x
578	INTEGER :: sd3x , ed3x , sp3x , ep3x , sm3x , em3x
579
580	INTEGER :: sd1y , ed1y , sp1y , ep1y , sm1y , em1y
581	INTEGER :: sd2y , ed2y , sp2y , ep2y , sm2y , em2y
582	INTEGER :: sd3y , ed3y , sp3y , ep3y , sm3y , em3y
583
584	TYPE(domain) , POINTER :: new_grid
585	INTEGER :: i
586	INTEGER :: parent_id , parent_domdesc , new_domdesc
587	INTEGER :: bdyzone_x , bdyzone_y
588	INTEGER :: nx, ny
589
590
591	! This next step uses information that is listed in the registry as namelist_derived
592	! to properly size the domain and the patches; this in turn is stored in the new_grid
593	! data structure
594
595
596	data_ordering : SELECT CASE ( model_data_order )
597	CASE ( DATA_ORDER_XYZ )
598
599	CALL nl_get_s_we( domain_id , sd1 )
600	CALL nl_get_e_we( domain_id , ed1 )
601	CALL nl_get_s_sn( domain_id , sd2 )
602	CALL nl_get_e_sn( domain_id , ed2 )
603	CALL nl_get_s_vert( domain_id , sd3 )
604	CALL nl_get_e_vert( domain_id , ed3 )
605	nx = ed1-sd1+1
606	ny = ed2-sd2+1
607
608	CASE ( DATA_ORDER_YXZ )
609
610	CALL nl_get_s_sn( domain_id , sd1 )
611	CALL nl_get_e_sn( domain_id , ed1 )
612	CALL nl_get_s_we( domain_id , sd2 )
613	CALL nl_get_e_we( domain_id , ed2 )
614	CALL nl_get_s_vert( domain_id , sd3 )
615	CALL nl_get_e_vert( domain_id , ed3 )
616	nx = ed2-sd2+1
617	ny = ed1-sd1+1
618
619	CASE ( DATA_ORDER_ZXY )
620
621	CALL nl_get_s_vert( domain_id , sd1 )
622	CALL nl_get_e_vert( domain_id , ed1 )
623	CALL nl_get_s_we( domain_id , sd2 )
624	CALL nl_get_e_we( domain_id , ed2 )
625	CALL nl_get_s_sn( domain_id , sd3 )
626	CALL nl_get_e_sn( domain_id , ed3 )
627	nx = ed2-sd2+1
628	ny = ed3-sd3+1
629
630	CASE ( DATA_ORDER_ZYX )
631
632	CALL nl_get_s_vert( domain_id , sd1 )
633	CALL nl_get_e_vert( domain_id , ed1 )
634	CALL nl_get_s_sn( domain_id , sd2 )
635	CALL nl_get_e_sn( domain_id , ed2 )
636	CALL nl_get_s_we( domain_id , sd3 )
637	CALL nl_get_e_we( domain_id , ed3 )
638	nx = ed3-sd3+1
639	ny = ed2-sd2+1
640
641	CASE ( DATA_ORDER_XZY )
642
643	CALL nl_get_s_we( domain_id , sd1 )
644	CALL nl_get_e_we( domain_id , ed1 )
645	CALL nl_get_s_vert( domain_id , sd2 )
646	CALL nl_get_e_vert( domain_id , ed2 )
647	CALL nl_get_s_sn( domain_id , sd3 )
648	CALL nl_get_e_sn( domain_id , ed3 )
649	nx = ed1-sd1+1
650	ny = ed3-sd3+1
651
652	CASE ( DATA_ORDER_YZX )
653
654	CALL nl_get_s_sn( domain_id , sd1 )
655	CALL nl_get_e_sn( domain_id , ed1 )
656	CALL nl_get_s_vert( domain_id , sd2 )
657	CALL nl_get_e_vert( domain_id , ed2 )
658	CALL nl_get_s_we( domain_id , sd3 )
659	CALL nl_get_e_we( domain_id , ed3 )
660	nx = ed3-sd3+1
661	ny = ed1-sd1+1
662
663	END SELECT data_ordering
664
665	IF ( num_time_levels > 3 ) THEN
666	WRITE ( wrf_err_message , * ) 'alloc_and_configure_domain: ', &
667	'Incorrect value for num_time_levels ', num_time_levels
668	CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
669	ENDIF
670
671	IF (ASSOCIATED(parent)) THEN
672	parent_id = parent%id
673	parent_domdesc = parent%domdesc
674	ELSE
675	parent_id = -1
676	parent_domdesc = -1
677	ENDIF
678
679	! provided by application, WRF defines in share/module_bc.F
680	CALL get_bdyzone_x( bdyzone_x )
681	CALL get_bdyzone_y( bdyzone_y )
682
683	ALLOCATE ( new_grid )
684	ALLOCATE( new_grid%head_statevars )
685	new_grid%head_statevars%Ndim = 0
686	NULLIFY( new_grid%head_statevars%next)
687	new_grid%tail_statevars => new_grid%head_statevars
688
689	ALLOCATE ( new_grid%parents( max_parents ) )
690	ALLOCATE ( new_grid%nests( max_nests ) )
691	NULLIFY( new_grid%sibling )
692	DO i = 1, max_nests
693	NULLIFY( new_grid%nests(i)%ptr )
694	ENDDO
695	NULLIFY (new_grid%next)
696	NULLIFY (new_grid%same_level)
697	NULLIFY (new_grid%i_start)
698	NULLIFY (new_grid%j_start)
699	NULLIFY (new_grid%i_end)
700	NULLIFY (new_grid%j_end)
701	ALLOCATE( new_grid%domain_clock )
702	new_grid%domain_clock_created = .FALSE.
703	ALLOCATE( new_grid%alarms( MAX_WRF_ALARMS ) ) ! initialize in setup_timekeeping
704	ALLOCATE( new_grid%alarms_created( MAX_WRF_ALARMS ) )
705	DO i = 1, MAX_WRF_ALARMS
706	new_grid%alarms_created( i ) = .FALSE.
707	ENDDO
708	new_grid%time_set = .FALSE.
709	new_grid%is_intermediate = .FALSE.
710	new_grid%have_displayed_alloc_stats = .FALSE.
711
712	new_grid%tiling_latch = .FALSE. ! 20121003
713
714	! set up the pointers that represent the nest hierarchy
715	! set this up prior to calling the patching or allocation
716	! routines so that implementations of these routines can
717	! traverse the nest hierarchy (through the root head_grid)
718	! if they need to
719
720
721	IF ( domain_id .NE. 1 ) THEN
722	new_grid%parents(1)%ptr => parent
723	new_grid%num_parents = 1
724	parent%nests(kid)%ptr => new_grid
725	new_grid%child_of_parent(1) = kid ! note assumption that nest can have only 1 parent
726	parent%num_nests = parent%num_nests + 1
727	END IF
728	new_grid%id = domain_id ! this needs to be assigned prior to calling wrf_patch_domain
729
730	CALL wrf_patch_domain( domain_id , new_domdesc , parent, parent_id, parent_domdesc , &
731
732	sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & ! z-xpose dims
733	sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & ! (standard)
734	sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
735
736	sp1x , ep1x , sm1x , em1x , & ! x-xpose dims
737	sp2x , ep2x , sm2x , em2x , &
738	sp3x , ep3x , sm3x , em3x , &
739
740	sp1y , ep1y , sm1y , em1y , & ! y-xpose dims
741	sp2y , ep2y , sm2y , em2y , &
742	sp3y , ep3y , sm3y , em3y , &
743
744	bdyzone_x , bdyzone_y , new_grid%bdy_mask &
745	)
746
747
748	new_grid%domdesc = new_domdesc
749	new_grid%num_nests = 0
750	new_grid%num_siblings = 0
751	new_grid%num_parents = 0
752	new_grid%max_tiles = 0
753	new_grid%num_tiles_spec = 0
754	new_grid%nframes = 0 ! initialize the number of frames per file (array assignment)
755	#if (EM_CORE == 1)
756	new_grid%stepping_to_time = .FALSE.
757	new_grid%adaptation_domain = 1
758	new_grid%last_step_updated = -1
759	#endif
760
761	CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. , &
762	sd1, ed1, sd2, ed2, sd3, ed3, &
763	sm1, em1, sm2, em2, sm3, em3, &
764	sp1, ep1, sp2, ep2, sp3, ep3, &
765	sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, &
766	sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, &
767	sm1x, em1x, sm2x, em2x, sm3x, em3x, & ! x-xpose
768	sm1y, em1y, sm2y, em2y, sm3y, em3y & ! y-xpose
769	)
770	#if MOVE_NESTS
771	!set these here, after alloc_space_field, which initializes vc_i, vc_j to zero
772	new_grid%xi = -1.0
773	new_grid%xj = -1.0
774	new_grid%vc_i = -1.0
775	new_grid%vc_j = -1.0
776	#endif
777
778	new_grid%sd31 = sd1
779	new_grid%ed31 = ed1
780	new_grid%sp31 = sp1
781	new_grid%ep31 = ep1
782	new_grid%sm31 = sm1
783	new_grid%em31 = em1
784	new_grid%sd32 = sd2
785	new_grid%ed32 = ed2
786	new_grid%sp32 = sp2
787	new_grid%ep32 = ep2
788	new_grid%sm32 = sm2
789	new_grid%em32 = em2
790	new_grid%sd33 = sd3
791	new_grid%ed33 = ed3
792	new_grid%sp33 = sp3
793	new_grid%ep33 = ep3
794	new_grid%sm33 = sm3
795	new_grid%em33 = em3
796
797	new_grid%sp31x = sp1x
798	new_grid%ep31x = ep1x
799	new_grid%sm31x = sm1x
800	new_grid%em31x = em1x
801	new_grid%sp32x = sp2x
802	new_grid%ep32x = ep2x
803	new_grid%sm32x = sm2x
804	new_grid%em32x = em2x
805	new_grid%sp33x = sp3x
806	new_grid%ep33x = ep3x
807	new_grid%sm33x = sm3x
808	new_grid%em33x = em3x
809
810	new_grid%sp31y = sp1y
811	new_grid%ep31y = ep1y
812	new_grid%sm31y = sm1y
813	new_grid%em31y = em1y
814	new_grid%sp32y = sp2y
815	new_grid%ep32y = ep2y
816	new_grid%sm32y = sm2y
817	new_grid%em32y = em2y
818	new_grid%sp33y = sp3y
819	new_grid%ep33y = ep3y
820	new_grid%sm33y = sm3y
821	new_grid%em33y = em3y
822
823	SELECT CASE ( model_data_order )
824	CASE ( DATA_ORDER_XYZ )
825	new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
826	new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
827	new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
828	new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
829	new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
830	new_grid%em21 = em1 ; new_grid%em22 = em2 ;
831	new_grid%sd11 = sd1
832	new_grid%ed11 = ed1
833	new_grid%sp11 = sp1
834	new_grid%ep11 = ep1
835	new_grid%sm11 = sm1
836	new_grid%em11 = em1
837	CASE ( DATA_ORDER_YXZ )
838	new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
839	new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
840	new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
841	new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
842	new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
843	new_grid%em21 = em1 ; new_grid%em22 = em2 ;
844	new_grid%sd11 = sd1
845	new_grid%ed11 = ed1
846	new_grid%sp11 = sp1
847	new_grid%ep11 = ep1
848	new_grid%sm11 = sm1
849	new_grid%em11 = em1
850	CASE ( DATA_ORDER_ZXY )
851	new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
852	new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
853	new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
854	new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
855	new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
856	new_grid%em21 = em2 ; new_grid%em22 = em3 ;
857	new_grid%sd11 = sd2
858	new_grid%ed11 = ed2
859	new_grid%sp11 = sp2
860	new_grid%ep11 = ep2
861	new_grid%sm11 = sm2
862	new_grid%em11 = em2
863	CASE ( DATA_ORDER_ZYX )
864	new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
865	new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
866	new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
867	new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
868	new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
869	new_grid%em21 = em2 ; new_grid%em22 = em3 ;
870	new_grid%sd11 = sd2
871	new_grid%ed11 = ed2
872	new_grid%sp11 = sp2
873	new_grid%ep11 = ep2
874	new_grid%sm11 = sm2
875	new_grid%em11 = em2
876	CASE ( DATA_ORDER_XZY )
877	new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
878	new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
879	new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
880	new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
881	new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
882	new_grid%em21 = em1 ; new_grid%em22 = em3 ;
883	new_grid%sd11 = sd1
884	new_grid%ed11 = ed1
885	new_grid%sp11 = sp1
886	new_grid%ep11 = ep1
887	new_grid%sm11 = sm1
888	new_grid%em11 = em1
889	CASE ( DATA_ORDER_YZX )
890	new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
891	new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
892	new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
893	new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
894	new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
895	new_grid%em21 = em1 ; new_grid%em22 = em3 ;
896	new_grid%sd11 = sd1
897	new_grid%ed11 = ed1
898	new_grid%sp11 = sp1
899	new_grid%ep11 = ep1
900	new_grid%sm11 = sm1
901	new_grid%em11 = em1
902	END SELECT
903
904	CALL med_add_config_info_to_grid ( new_grid ) ! this is a mediation layer routine
905
906	! Some miscellaneous state that is in the Registry but not namelist data
907
908	new_grid%tiled = .false.
909	new_grid%patched = .false.
910	NULLIFY(new_grid%mapping)
911
912	! This next set of includes causes all but the namelist_derived variables to be
913	! properly assigned to the new_grid record
914
915	grid => new_grid
916
917	! Allocate storage for time series metadata
918	ALLOCATE( grid%lattsloc( grid%max_ts_locs ) )
919	ALLOCATE( grid%lontsloc( grid%max_ts_locs ) )
920	ALLOCATE( grid%nametsloc( grid%max_ts_locs ) )
921	ALLOCATE( grid%desctsloc( grid%max_ts_locs ) )
922	ALLOCATE( grid%itsloc( grid%max_ts_locs ) )
923	ALLOCATE( grid%jtsloc( grid%max_ts_locs ) )
924	ALLOCATE( grid%id_tsloc( grid%max_ts_locs ) )
925	ALLOCATE( grid%ts_filename( grid%max_ts_locs ) )
926	grid%ntsloc = 0
927	grid%ntsloc_domain = 0
928
929	#if WRFMEAS
930	! L. Fita, LMD. May 2014
931	ALLOCATE( grid%latlidarloc( grid%max_lidar_locs ) )
932	ALLOCATE( grid%lonlidarloc( grid%max_lidar_locs ) )
933	ALLOCATE( grid%namelidarloc( grid%max_lidar_locs ) )
934	ALLOCATE( grid%desclidarloc( grid%max_lidar_locs ) )
935	ALLOCATE( grid%ilidarloc( grid%max_lidar_locs ) )
936	ALLOCATE( grid%jlidarloc( grid%max_lidar_locs ) )
937	ALLOCATE( grid%id_lidarloc( grid%max_lidar_locs ) )
938	ALLOCATE( grid%lidar_filename( grid%max_lidar_locs ) )
939	grid%nlidarloc = 0
940	grid%nlidarloc_domain = 0
941	#endif
942
943	#if (EM_CORE == 1)
944	! Allocate storage for track metadata
945	ALLOCATE( grid%track_time_in( grid%track_loc_in ) )
946	ALLOCATE( grid%track_lat_in( grid%track_loc_in ) )
947	ALLOCATE( grid%track_lon_in( grid%track_loc_in ) )
948
949	ALLOCATE( grid%track_time_domain( grid%track_loc_in ) )
950	ALLOCATE( grid%track_lat_domain( grid%track_loc_in ) )
951	ALLOCATE( grid%track_lon_domain( grid%track_loc_in ) )
952	ALLOCATE( grid%track_i( grid%track_loc_in ) )
953	ALLOCATE( grid%track_j( grid%track_loc_in ) )
954
955	grid%track_loc = 0
956	grid%track_loc_domain = 0
957	grid%track_have_calculated = .FALSE.
958	grid%track_have_input = .FALSE.
959	#endif
960	#ifdef DM_PARALLEL
961	CALL wrf_get_dm_communicator ( grid%communicator )
962	CALL wrf_dm_define_comms( grid )
963	#endif
964
965	#if ( NMM_CORE==1 )
966	grid%interp_mp = .not. ( size(grid%f_ice)>1 .or. size(grid%f_rain)>1 .or. size(grid%f_rimef)>1 )
967	#else
968	grid%interp_mp = .true.
969	#endif
970
971	END SUBROUTINE alloc_and_configure_domain
972
973	SUBROUTINE get_fieldstr(ix,c,instr,outstr,noutstr,noerr)
974	IMPLICIT NONE
975	INTEGER, INTENT(IN) :: ix
976	CHARACTER(), INTENT(IN) :: c
977	CHARACTER(), INTENT(IN) :: instr
978	CHARACTER(), INTENT(OUT) :: outstr
979	INTEGER, INTENT(IN) :: noutstr ! length of outstr
980	LOGICAL, INTENT(INOUT) :: noerr ! status
981	!local
982	INTEGER, PARAMETER :: MAX_DEXES = 100
983	INTEGER I, PREV, IDEX
984	INTEGER DEXES(MAX_DEXES)
985	outstr = ""
986	prev = 1
987	dexes(1) = 1
988	DO i = 2,MAX_DEXES
989	idex = INDEX(instr(prev:LEN(TRIM(instr))),c)
990	IF ( idex .GT. 0 ) THEN
991	dexes(i) = idex+prev
992	prev = dexes(i)+1
993	ELSE
994	dexes(i) = LEN(TRIM(instr))+2
995	ENDIF
996	ENDDO
997
998	IF ( (dexes(ix+1)-2)-(dexes(ix)) .GT. noutstr ) THEN
999	noerr = .FALSE. ! would overwrite
1000	ELSE IF( dexes(ix) .EQ. dexes(ix+1) ) THEN
1001	noerr = .FALSE. ! not found
1002	ELSE
1003	outstr = instr(dexes(ix):(dexes(ix+1)-2))
1004	noerr = noerr .AND. .TRUE.
1005	ENDIF
1006	END SUBROUTINE get_fieldstr
1007
1008	SUBROUTINE change_to_lower_case(instr,outstr)
1009	CHARACTER() ,INTENT(IN) :: instr
1010	CHARACTER() ,INTENT(OUT) :: outstr
1011	!Local
1012	CHARACTER*1 :: c
1013	INTEGER ,PARAMETER :: upper_to_lower =IACHAR('a')-IACHAR('A')
1014	INTEGER :: i,n,n1
1015	!
1016	outstr = ' '
1017	N = len(instr)
1018	N1 = len(outstr)
1019	N = MIN(N,N1)
1020	outstr(1:N) = instr(1:N)
1021	DO i=1,N
1022	c = instr(i:i)
1023	if('A'<=c .and. c <='Z') outstr(i:i)=achar(iachar(c)+upper_to_lower)
1024	ENDDO
1025	RETURN
1026	END SUBROUTINE change_to_lower_case
1027
1028	!
1029	SUBROUTINE modify_io_masks1 ( grid , id )
1030	IMPLICIT NONE
1031	#include "streams.h"
1032	INTEGER , INTENT(IN ) :: id
1033	TYPE(domain), POINTER :: grid
1034	! Local
1035	TYPE(fieldlist), POINTER :: p, q
1036	INTEGER, PARAMETER :: read_unit = 10
1037	LOGICAL, EXTERNAL :: wrf_dm_on_monitor
1038	CHARACTER*256 :: fname, inln, mess, dname, t1, lookee
1039	CHARACTER*256 :: fieldlst
1040	CHARACTER*1 :: op, strmtyp
1041	CHARACTER*3 :: strmid
1042	CHARACTER*10 :: strmtyp_name
1043	INTEGER :: io_status
1044	INTEGER :: strmtyp_int, count_em
1045	INTEGER :: lineno, fieldno, istrm, retval, itrace
1046	LOGICAL :: keepgoing, noerr, gavewarning, ignorewarning, found
1047	LOGICAL, SAVE :: you_warned_me = .FALSE.
1048	LOGICAL, SAVE :: you_warned_me2(max_hst_mods,max_domains) = .FALSE.
1049
1050	gavewarning = .FALSE.
1051
1052	CALL nl_get_iofields_filename( id, fname )
1053
1054	IF ( grid%is_intermediate ) RETURN ! short circuit
1055	IF ( TRIM(fname) .EQ. "NONE_SPECIFIED" ) RETURN ! short circuit
1056
1057	IF ( wrf_dm_on_monitor() ) THEN
1058	OPEN ( UNIT = read_unit , &
1059	FILE = TRIM(fname) , &
1060	FORM = "FORMATTED" , &
1061	STATUS = "OLD" , &
1062	IOSTAT = io_status )
1063	IF ( io_status .EQ. 0 ) THEN ! only on success
1064	keepgoing = .TRUE.
1065	lineno = 0
1066	count_em = 0 ! Count the total number of fields
1067	DO WHILE ( keepgoing )
1068	READ(UNIT=read_unit,FMT='(A)',IOSTAT=io_status) inln
1069	keepgoing = (io_status .EQ. 0) .AND. (LEN(TRIM(inln)) .GT. 0)
1070	IF ( keepgoing ) THEN
1071	lineno = lineno + 1
1072	IF ( .NOT. LEN(TRIM(inln)) .LT. LEN(inln) ) THEN
1073	WRITE(mess,*)'W A R N I N G : Line ',lineno,' of ',TRIM(fname),' is too long. Limit is ',LEN(inln),' characters.'
1074	gavewarning = .TRUE.
1075	ENDIF
1076	IF ( INDEX(inln,'#') .EQ. 0 ) THEN ! skip comments, which is a # anywhere on line
1077	IF ( keepgoing ) THEN
1078	noerr = .TRUE.
1079	CALL get_fieldstr(1,':',inln,op,1,noerr) ! + is add, - is remove
1080	IF ( TRIM(op) .NE. '+' .AND. TRIM(op) .NE. '-' ) THEN
1081	WRITE(mess,*)'W A R N I N G : unknown operation ',TRIM(op),' (should be + or -). Line ',lineno
1082	gavewarning = .TRUE.
1083	ENDIF
1084	CALL get_fieldstr(2,':',inln,t1,1,noerr) ! i is input, h is history
1085	CALL change_to_lower_case(t1,strmtyp)
1086
1087	SELECT CASE (TRIM(strmtyp))
1088	CASE ('h')
1089	strmtyp_name = 'history'
1090	strmtyp_int = first_history
1091	CASE ('i')
1092	strmtyp_name = 'input'
1093	strmtyp_int = first_input
1094	CASE DEFAULT
1095	WRITE(mess,*)'W A R N I N G : unknown stream type ',TRIM(strmtyp),'. Line ',lineno
1096	gavewarning = .TRUE.
1097	END SELECT
1098
1099	CALL get_fieldstr(3,':',inln,strmid,3,noerr) ! number of stream (main input and hist are 0)
1100	READ(strmid,'(I3)') istrm
1101	IF ( istrm .LT. 0 .OR. istrm .GT. last_history ) THEN
1102	WRITE(mess,*)'W A R N I N G : invalid stream id ',istrm,' (should be 0 <= id <= ',last_history,'). Line ',lineno
1103	gavewarning = .TRUE.
1104	ENDIF
1105	CALL get_fieldstr(4,':',inln,fieldlst,1024,noerr) ! get list of fields
1106	IF ( noerr ) THEN
1107	fieldno = 1
1108	CALL get_fieldstr(fieldno,',',fieldlst,t1,256,noerr)
1109	CALL change_to_lower_case(t1,lookee)
1110	DO WHILE ( noerr ) ! linear search, blargh...
1111	p => grid%head_statevars%next
1112	found = .FALSE.
1113	count_em = count_em + 1
1114	DO WHILE ( ASSOCIATED( p ) )
1115
1116	IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
1117
1118	DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
1119	CALL change_to_lower_case( p%dname_table( grid%id, itrace ) , dname )
1120
1121	IF ( TRIM(dname) .EQ. TRIM(lookee) ) &
1122	CALL warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
1123	strmtyp_name, dname, fname, lookee, &
1124	p%streams_table(grid%id,itrace)%stream, &
1125	mess, found, you_warned_me2)
1126	ENDDO
1127	ELSE
1128	IF ( p%Ntl .GT. 0 ) THEN
1129	CALL change_to_lower_case(p%DataName(1:LEN(TRIM(p%DataName))-2),dname)
1130	ELSE
1131	CALL change_to_lower_case(p%DataName,dname)
1132	ENDIF
1133
1134	IF ( TRIM(dname) .EQ. TRIM(lookee) ) &
1135	CALL warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
1136	strmtyp_name, dname, fname, lookee, &
1137	p%streams, mess, found, you_warned_me2)
1138	ENDIF
1139	p => p%next
1140	ENDDO
1141	IF ( .NOT. found ) THEN
1142	WRITE(mess,*)'W A R N I N G : Unable to modify mask for ',TRIM(lookee),&
1143	'. Variable not found. File: ',TRIM(fname),' at line ',lineno
1144	CALL wrf_message(mess)
1145	gavewarning = .TRUE.
1146	ENDIF
1147	fieldno = fieldno + 1
1148	CALL get_fieldstr(fieldno,',',fieldlst,t1,256,noerr)
1149	CALL change_to_lower_case(t1,lookee)
1150	ENDDO
1151	ELSE
1152	WRITE(mess,*)'W A R N I N G : Problem reading ',TRIM(fname),' at line ',lineno
1153	CALL wrf_message(mess)
1154	gavewarning = .TRUE.
1155	ENDIF
1156	ENDIF ! keepgoing
1157	ENDIF ! skip comments
1158	ENDIF ! keepgoing
1159	ENDDO
1160	ELSE
1161	WRITE(mess,*)'W A R N I N G : Problem opening ',TRIM(fname)
1162	CALL wrf_message(mess)
1163	gavewarning = .TRUE.
1164	ENDIF
1165	CLOSE( read_unit )
1166	IF ( gavewarning ) THEN
1167	CALL nl_get_ignore_iofields_warning(1,ignorewarning)
1168	IF ( .NOT. ignorewarning ) THEN
1169	CALL wrf_message(mess)
1170	WRITE(mess,*)'modify_io_masks: problems reading ',TRIM(fname)
1171	CALL wrf_message(mess)
1172	CALL wrf_error_fatal('Set ignore_iofields_warn to true in namelist to ignore')
1173	ELSE
1174	IF ( .NOT. you_warned_me ) THEN
1175	if ( .NOT. you_warned_me2(count_em,id) ) CALL wrf_message(mess) ! Don't repeat the W A R N I N G message
1176	WRITE(mess,*)'Ignoring problems reading ',TRIM(fname)
1177	CALL wrf_message(mess)
1178	CALL wrf_message('Continuing. To make this a fatal error, set ignore_iofields_warn to false in namelist' )
1179	CALL wrf_message(' ')
1180	you_warned_me = .TRUE.
1181	ENDIF
1182	ENDIF
1183	ENDIF
1184	ENDIF ! wrf_dm_on_monitor
1185
1186	#ifdef DM_PARALLEL
1187	! broadcast the new masks to the other tasks
1188	p => grid%head_statevars%next
1189	DO WHILE ( ASSOCIATED( p ) )
1190	IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
1191
1192	DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id)
1193	CALL wrf_dm_bcast_integer( p%streams_table(grid%id,itrace)%stream, IO_MASK_SIZE )
1194	ENDDO
1195
1196	ELSE
1197	CALL wrf_dm_bcast_integer( p%streams, IO_MASK_SIZE )
1198	ENDIF
1199	p => p%next
1200	ENDDO
1201	#endif
1202
1203	END SUBROUTINE modify_io_masks1
1204
1205	SUBROUTINE warn_me_or_set_mask (id, istrm, lineno, strmtyp_int, count_em, op, &
1206	strmtyp_name, dname, fname, lookee, &
1207	p_stream, mess, found, you_warned_me2)
1208
1209	IMPLICIT NONE
1210
1211	! See if a field that is requested to be added to or removed from the I/O stream
1212	! is already present or absent
1213	! If the requested action has already been done, write a warning message
1214	! If not, satisfy the request
1215
1216	INTEGER, INTENT(IN ) :: id, istrm, lineno, strmtyp_int
1217	INTEGER, INTENT(IN ) :: p_stream(*), count_em
1218	CHARACTER*1, INTENT(IN ) :: op
1219	CHARACTER*10, INTENT(IN ) :: strmtyp_name
1220	CHARACTER*256, INTENT(IN ) :: dname, fname, lookee
1221	CHARACTER*256, INTENT(OUT) :: mess
1222	LOGICAL, INTENT(OUT) :: found
1223	LOGICAL, INTENT(INOUT) :: you_warned_me2(max_hst_mods,max_domains)
1224	! Local
1225	INTEGER :: retval
1226
1227	found = .TRUE.
1228	IF ( TRIM(op) .EQ. '+' ) THEN
1229	CALL get_mask( p_stream, strmtyp_int + istrm - 1, retval )
1230	IF ( retval .NE. 0 ) THEN
1231	WRITE(mess,*) 'Domain ',id, ' W A R N I N G : Variable ',TRIM(lookee),' already on ', &
1232	TRIM(strmtyp_name), ' stream ',istrm, '. File: ', TRIM(fname),' at line ',lineno
1233	ELSE
1234	WRITE(mess,*) 'Domain ', id, ' Setting ', TRIM(strmtyp_name), ' stream ',istrm,' for ', &
1235	TRIM(DNAME) ; CALL wrf_debug(1,mess)
1236	CALL set_mask( p_stream, strmtyp_int + istrm - 1 )
1237	ENDIF
1238	ELSE IF ( TRIM(op) .EQ. '-' ) THEN
1239	CALL get_mask( p_stream, strmtyp_int + istrm - 1, retval )
1240	IF ( retval .EQ. 0 ) THEN
1241	WRITE(mess,*) 'Domain ',id, ' W A R N I N G : Variable ',TRIM(lookee),' already off ', &
1242	TRIM(strmtyp_name), ' stream ',istrm, '. File: ',TRIM(fname),' at line ',lineno
1243	ELSE
1244	WRITE(mess,*) 'Domain ', id, ' Resetting ', TRIM(strmtyp_name), ' stream ',istrm,' for ', &
1245	TRIM(DNAME) ; CALL wrf_debug(1,mess)
1246	CALL reset_mask( p_stream, strmtyp_int + istrm - 1)
1247	ENDIF
1248	ENDIF
1249	IF ( count_em > max_hst_mods ) THEN
1250	WRITE(mess,*)'ERROR module_domain: Array size for you_warned_me2 is fixed at ',max_hst_mods
1251	CALL wrf_message(mess)
1252	CALL wrf_error_fatal('Did you really type > max_hst_mods fields into ', TRIM(fname) ,' ?')
1253	ELSE
1254	IF ( .NOT. you_warned_me2(count_em,id) ) THEN
1255	CALL wrf_message(mess) ! Write warning message once for each field
1256	you_warned_me2(count_em,id) = .TRUE.
1257	ENDIF
1258	ENDIF
1259
1260	END SUBROUTINE warn_me_or_set_mask
1261
1262	! This routine ALLOCATEs the required space for the meteorological fields
1263	! for a specific domain. The fields are simply ALLOCATEd as an -1. They
1264	! are referenced as wind, temperature, moisture, etc. in routines that are
1265	! below this top-level of data allocation and management (in the solve routine
1266	! and below).
1267
1268	SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , &
1269	sd31, ed31, sd32, ed32, sd33, ed33, &
1270	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1271	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1272	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1273	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1274	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1275	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1276
1277	USE module_alloc_space_0, ONLY : alloc_space_field_core_0
1278	USE module_alloc_space_1, ONLY : alloc_space_field_core_1
1279	USE module_alloc_space_2, ONLY : alloc_space_field_core_2
1280	USE module_alloc_space_3, ONLY : alloc_space_field_core_3
1281	USE module_alloc_space_4, ONLY : alloc_space_field_core_4
1282	USE module_alloc_space_5, ONLY : alloc_space_field_core_5
1283	USE module_alloc_space_6, ONLY : alloc_space_field_core_6
1284	USE module_alloc_space_7, ONLY : alloc_space_field_core_7
1285	USE module_alloc_space_8, ONLY : alloc_space_field_core_8
1286	USE module_alloc_space_9, ONLY : alloc_space_field_core_9
1287
1288	IMPLICIT NONE
1289
1290	! Input data.
1291
1292	TYPE(domain) , POINTER :: grid
1293	INTEGER , INTENT(IN) :: id
1294	INTEGER , INTENT(IN) :: setinitval_in ! 3 = everything, 1 = arrays only, 0 = none
1295	INTEGER , INTENT(IN) :: sd31, ed31, sd32, ed32, sd33, ed33
1296	INTEGER , INTENT(IN) :: sm31, em31, sm32, em32, sm33, em33
1297	INTEGER , INTENT(IN) :: sp31, ep31, sp32, ep32, sp33, ep33
1298	INTEGER , INTENT(IN) :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x
1299	INTEGER , INTENT(IN) :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y
1300	INTEGER , INTENT(IN) :: sm31x, em31x, sm32x, em32x, sm33x, em33x
1301	INTEGER , INTENT(IN) :: sm31y, em31y, sm32y, em32y, sm33y, em33y
1302
1303	! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.
1304	! e.g. to set both 1st and second time level, use 3
1305	! to set only 1st use 1
1306	! to set only 2st use 2
1307	INTEGER , INTENT(IN) :: tl_in
1308
1309	! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated
1310	! false otherwise (all allocated, modulo tl above)
1311	LOGICAL , INTENT(IN) :: inter_domain_in
1312
1313	! Local
1314	INTEGER(KIND=8) num_bytes_allocated
1315	INTEGER idum1, idum2
1316
1317	#if (EM_CORE == 1)
1318	IF ( grid%id .EQ. 1 ) CALL wrf_message ( &
1319	'DYNAMICS OPTION: Eulerian Mass Coordinate ')
1320	#endif
1321	#if (NMM_CORE == 1)
1322	IF ( grid%id .EQ. 1 ) &
1323	CALL wrf_message ( 'DYNAMICS OPTION: nmm dyncore' )
1324	#endif
1325	#if (COAMPS_CORE == 1)
1326	IF ( grid%id .EQ. 1 ) &
1327	CALL wrf_message ( 'DYNAMICS OPTION: coamps dyncore' )
1328	#endif
1329
1330	CALL set_scalar_indices_from_config( id , idum1 , idum2 )
1331
1332	num_bytes_allocated = 0
1333
1334	! now separate modules to reduce the size of module_domain that the compiler sees
1335	CALL alloc_space_field_core_0 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , &
1336	sd31, ed31, sd32, ed32, sd33, ed33, &
1337	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1338	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1339	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1340	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1341	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1342	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1343	CALL alloc_space_field_core_1 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , &
1344	sd31, ed31, sd32, ed32, sd33, ed33, &
1345	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1346	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1347	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1348	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1349	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1350	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1351	CALL alloc_space_field_core_2 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , &
1352	sd31, ed31, sd32, ed32, sd33, ed33, &
1353	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1354	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1355	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1356	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1357	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1358	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1359	CALL alloc_space_field_core_3 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , &
1360	sd31, ed31, sd32, ed32, sd33, ed33, &
1361	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1362	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1363	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1364	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1365	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1366	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1367	CALL alloc_space_field_core_4 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , &
1368	sd31, ed31, sd32, ed32, sd33, ed33, &
1369	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1370	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1371	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1372	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1373	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1374	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1375	CALL alloc_space_field_core_5 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , &
1376	sd31, ed31, sd32, ed32, sd33, ed33, &
1377	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1378	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1379	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1380	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1381	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1382	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1383	CALL alloc_space_field_core_6 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , &
1384	sd31, ed31, sd32, ed32, sd33, ed33, &
1385	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1386	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1387	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1388	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1389	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1390	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1391	CALL alloc_space_field_core_7 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , &
1392	sd31, ed31, sd32, ed32, sd33, ed33, &
1393	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1394	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1395	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1396	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1397	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1398	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1399	CALL alloc_space_field_core_8 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , &
1400	sd31, ed31, sd32, ed32, sd33, ed33, &
1401	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1402	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1403	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1404	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1405	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1406	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1407	CALL alloc_space_field_core_9 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , &
1408	sd31, ed31, sd32, ed32, sd33, ed33, &
1409	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1410	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1411	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1412	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1413	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1414	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1415
1416	IF ( .NOT. grid%have_displayed_alloc_stats ) THEN
1417	! we do not want to see this message more than once, as can happen with the allocation and
1418	! deallocation of intermediate domains used in nesting.
1419	WRITE(wrf_err_message,*)&
1420	'alloc_space_field: domain ',id,', ',num_bytes_allocated,' bytes allocated'
1421	CALL wrf_debug( 0, wrf_err_message )
1422	grid%have_displayed_alloc_stats = .TRUE.
1423	ENDIF
1424
1425
1426	grid%alloced_sd31=sd31
1427	grid%alloced_ed31=ed31
1428	grid%alloced_sd32=sd32
1429	grid%alloced_ed32=ed32
1430	grid%alloced_sd33=sd33
1431	grid%alloced_ed33=ed33
1432	grid%alloced_sm31=sm31
1433	grid%alloced_em31=em31
1434	grid%alloced_sm32=sm32
1435	grid%alloced_em32=em32
1436	grid%alloced_sm33=sm33
1437	grid%alloced_em33=em33
1438	grid%alloced_sm31x=sm31x
1439	grid%alloced_em31x=em31x
1440	grid%alloced_sm32x=sm32x
1441	grid%alloced_em32x=em32x
1442	grid%alloced_sm33x=sm33x
1443	grid%alloced_em33x=em33x
1444	grid%alloced_sm31y=sm31y
1445	grid%alloced_em31y=em31y
1446	grid%alloced_sm32y=sm32y
1447	grid%alloced_em32y=em32y
1448	grid%alloced_sm33y=sm33y
1449	grid%alloced_em33y=em33y
1450
1451	grid%allocated=.TRUE.
1452
1453	END SUBROUTINE alloc_space_field
1454
1455	! Ensure_space_field allocates a grid's arrays if they are not yet
1456	! allocated. If they were already allocated, then it deallocates and
1457	! reallocates them if they were allocated with different dimensions.
1458	! If they were already allocated with the requested dimensions, then
1459	! ensure_space_field does nothing.
1460
1461	SUBROUTINE ensure_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , &
1462	sd31, ed31, sd32, ed32, sd33, ed33, &
1463	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1464	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1465	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1466	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1467	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1468	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1469
1470	IMPLICIT NONE
1471
1472	! Input data.
1473
1474	TYPE(domain) , POINTER :: grid
1475	INTEGER , INTENT(IN) :: id
1476	INTEGER , INTENT(IN) :: setinitval_in ! 3 = everything, 1 = arrays only, 0 = none
1477	INTEGER , INTENT(IN) :: sd31, ed31, sd32, ed32, sd33, ed33
1478	INTEGER , INTENT(IN) :: sm31, em31, sm32, em32, sm33, em33
1479	INTEGER , INTENT(IN) :: sp31, ep31, sp32, ep32, sp33, ep33
1480	INTEGER , INTENT(IN) :: sp31x, ep31x, sp32x, ep32x, sp33x, ep33x
1481	INTEGER , INTENT(IN) :: sp31y, ep31y, sp32y, ep32y, sp33y, ep33y
1482	INTEGER , INTENT(IN) :: sm31x, em31x, sm32x, em32x, sm33x, em33x
1483	INTEGER , INTENT(IN) :: sm31y, em31y, sm32y, em32y, sm33y, em33y
1484
1485	! this argument is a bitmask. First bit is time level 1, second is time level 2, and so on.
1486	! e.g. to set both 1st and second time level, use 3
1487	! to set only 1st use 1
1488	! to set only 2st use 2
1489	INTEGER , INTENT(IN) :: tl_in
1490
1491	! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated
1492	! false otherwise (all allocated, modulo tl above)
1493	LOGICAL , INTENT(IN) :: inter_domain_in
1494	LOGICAL :: size_changed
1495
1496	size_changed= .not. ( &
1497	grid%alloced_sd31 .eq. sd31 .and. grid%alloced_ed31 .eq. ed31 .and. &
1498	grid%alloced_sd32 .eq. sd32 .and. grid%alloced_ed32 .eq. ed32 .and. &
1499	grid%alloced_sd33 .eq. sd33 .and. grid%alloced_ed33 .eq. ed33 .and. &
1500	grid%alloced_sm31 .eq. sm31 .and. grid%alloced_em31 .eq. em31 .and. &
1501	grid%alloced_sm32 .eq. sm32 .and. grid%alloced_em32 .eq. em32 .and. &
1502	grid%alloced_sm33 .eq. sm33 .and. grid%alloced_em33 .eq. em33 .and. &
1503	grid%alloced_sm31x .eq. sm31x .and. grid%alloced_em31x .eq. em31x .and. &
1504	grid%alloced_sm32x .eq. sm32x .and. grid%alloced_em32x .eq. em32x .and. &
1505	grid%alloced_sm33x .eq. sm33x .and. grid%alloced_em33x .eq. em33x .and. &
1506	grid%alloced_sm31y .eq. sm31y .and. grid%alloced_em31y .eq. em31y .and. &
1507	grid%alloced_sm32y .eq. sm32y .and. grid%alloced_em32y .eq. em32y .and. &
1508	grid%alloced_sm33y .eq. sm33y .and. grid%alloced_em33y .eq. em33y &
1509	)
1510	if(.not. grid%allocated .or. size_changed) then
1511	if(.not. grid%allocated) then
1512	call wrf_debug(1,'ensure_space_field: calling alloc_space_field because a grid was not allocated.')
1513	else
1514	if(size_changed) &
1515	call wrf_debug(1,'ensure_space_field: deallocating and reallocating a grid because grid size changed.')
1516	end if
1517	if(grid%allocated) &
1518	call dealloc_space_field( grid )
1519	call alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , &
1520	sd31, ed31, sd32, ed32, sd33, ed33, &
1521	sm31 , em31 , sm32 , em32 , sm33 , em33 , &
1522	sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , &
1523	sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
1524	sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
1525	sm31x, em31x, sm32x, em32x, sm33x, em33x, &
1526	sm31y, em31y, sm32y, em32y, sm33y, em33y )
1527	end if
1528
1529	END SUBROUTINE ensure_space_field
1530
1531	! This routine is used to DEALLOCATE space for a single domain and remove
1532	! it from the linked list. First the pointers in the linked list are fixed
1533	! (so the one in the middle can be removed). Then the domain itself is
1534	! DEALLOCATEd via a call to domain_destroy().
1535
1536	SUBROUTINE dealloc_space_domain ( id )
1537
1538	IMPLICIT NONE
1539
1540	! Input data.
1541
1542	INTEGER , INTENT(IN) :: id
1543
1544	! Local data.
1545
1546	TYPE(domain) , POINTER :: grid
1547	LOGICAL :: found
1548
1549	! Initializations required to start the routine.
1550
1551	grid => head_grid
1552	old_grid => head_grid
1553	found = .FALSE.
1554
1555	! The identity of the domain to delete is based upon the "id".
1556	! We search all of the possible grids. It is required to find a domain
1557	! otherwise it is a fatal error.
1558
1559	find_grid : DO WHILE ( ASSOCIATED(grid) )
1560	IF ( grid%id == id ) THEN
1561	found = .TRUE.
1562	old_grid%next => grid%next
1563	CALL domain_destroy( grid )
1564	EXIT find_grid
1565	END IF
1566	old_grid => grid
1567	grid => grid%next
1568	END DO find_grid
1569
1570	IF ( .NOT. found ) THEN
1571	WRITE ( wrf_err_message , * ) 'module_domain: ', &
1572	'dealloc_space_domain: Could not de-allocate grid id ',id
1573	CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
1574	END IF
1575
1576	END SUBROUTINE dealloc_space_domain
1577
1578
1579
1580	! This routine is used to DEALLOCATE space for a single domain type.
1581	! First, the field data are all removed through a CALL to the
1582	! dealloc_space_field routine. Then the pointer to the domain
1583	! itself is DEALLOCATEd.
1584
1585	SUBROUTINE domain_destroy ( grid )
1586
1587	IMPLICIT NONE
1588
1589	! Input data.
1590
1591	TYPE(domain) , POINTER :: grid
1592
1593	CALL dealloc_space_field ( grid )
1594	CALL dealloc_linked_lists( grid )
1595	DEALLOCATE( grid%parents )
1596	DEALLOCATE( grid%nests )
1597	! clean up time manager bits
1598	CALL domain_clock_destroy( grid )
1599	CALL domain_alarms_destroy( grid )
1600	IF ( ASSOCIATED( grid%i_start ) ) THEN
1601	DEALLOCATE( grid%i_start )
1602	ENDIF
1603	IF ( ASSOCIATED( grid%i_end ) ) THEN
1604	DEALLOCATE( grid%i_end )
1605	ENDIF
1606	IF ( ASSOCIATED( grid%j_start ) ) THEN
1607	DEALLOCATE( grid%j_start )
1608	ENDIF
1609	IF ( ASSOCIATED( grid%j_end ) ) THEN
1610	DEALLOCATE( grid%j_end )
1611	ENDIF
1612	IF ( ASSOCIATED( grid%itsloc ) ) THEN
1613	DEALLOCATE( grid%itsloc )
1614	ENDIF
1615	IF ( ASSOCIATED( grid%jtsloc ) ) THEN
1616	DEALLOCATE( grid%jtsloc )
1617	ENDIF
1618	IF ( ASSOCIATED( grid%id_tsloc ) ) THEN
1619	DEALLOCATE( grid%id_tsloc )
1620	ENDIF
1621	IF ( ASSOCIATED( grid%lattsloc ) ) THEN
1622	DEALLOCATE( grid%lattsloc )
1623	ENDIF
1624	IF ( ASSOCIATED( grid%lontsloc ) ) THEN
1625	DEALLOCATE( grid%lontsloc )
1626	ENDIF
1627	IF ( ASSOCIATED( grid%nametsloc ) ) THEN
1628	DEALLOCATE( grid%nametsloc )
1629	ENDIF
1630	IF ( ASSOCIATED( grid%desctsloc ) ) THEN
1631	DEALLOCATE( grid%desctsloc )
1632	ENDIF
1633	IF ( ASSOCIATED( grid%ts_filename ) ) THEN
1634	DEALLOCATE( grid%ts_filename )
1635	ENDIF
1636
1637	#if WRFMEAS
1638	! L. Fita, LMD. May 2014
1639	IF ( ASSOCIATED( grid%ilidarloc ) ) THEN
1640	DEALLOCATE( grid%ilidarloc )
1641	ENDIF
1642	IF ( ASSOCIATED( grid%jlidarloc ) ) THEN
1643	DEALLOCATE( grid%jlidarloc )
1644	ENDIF
1645	IF ( ASSOCIATED( grid%id_lidarloc ) ) THEN
1646	DEALLOCATE( grid%id_lidarloc )
1647	ENDIF
1648	IF ( ASSOCIATED( grid%latlidarloc ) ) THEN
1649	DEALLOCATE( grid%latlidarloc )
1650	ENDIF
1651	IF ( ASSOCIATED( grid%lonlidarloc ) ) THEN
1652	DEALLOCATE( grid%lonlidarloc )
1653	ENDIF
1654	IF ( ASSOCIATED( grid%namelidarloc ) ) THEN
1655	DEALLOCATE( grid%namelidarloc )
1656	ENDIF
1657	IF ( ASSOCIATED( grid%desclidarloc ) ) THEN
1658	DEALLOCATE( grid%desclidarloc )
1659	ENDIF
1660	IF ( ASSOCIATED( grid%lidar_filename ) ) THEN
1661	DEALLOCATE( grid%lidar_filename )
1662	ENDIF
1663	#endif
1664
1665	#if (EM_CORE == 1)
1666	IF ( ASSOCIATED( grid%track_time_in ) ) THEN
1667	DEALLOCATE( grid%track_time_in )
1668	ENDIF
1669
1670	IF ( ASSOCIATED( grid%track_lat_in ) ) THEN
1671	DEALLOCATE( grid%track_lat_in )
1672	ENDIF
1673
1674	IF ( ASSOCIATED( grid%track_lon_in ) ) THEN
1675	DEALLOCATE( grid%track_lon_in )
1676	ENDIF
1677
1678	IF ( ASSOCIATED( grid%track_i ) ) THEN
1679	DEALLOCATE( grid%track_i )
1680	ENDIF
1681
1682	IF ( ASSOCIATED( grid%track_j ) ) THEN
1683	DEALLOCATE( grid%track_j )
1684	ENDIF
1685
1686	IF ( ASSOCIATED( grid%track_time_domain ) ) THEN
1687	DEALLOCATE( grid%track_time_domain )
1688	ENDIF
1689
1690	IF ( ASSOCIATED( grid%track_lat_domain ) ) THEN
1691	DEALLOCATE( grid%track_lat_domain )
1692	ENDIF
1693
1694	IF ( ASSOCIATED( grid%track_lon_domain ) ) THEN
1695	DEALLOCATE( grid%track_lon_domain )
1696	ENDIF
1697	#endif
1698	DEALLOCATE( grid )
1699	NULLIFY( grid )
1700
1701	END SUBROUTINE domain_destroy
1702
1703	SUBROUTINE dealloc_linked_lists ( grid )
1704	IMPLICIT NONE
1705	TYPE(domain), POINTER :: grid
1706	TYPE(fieldlist), POINTER :: p, q
1707	p => grid%head_statevars
1708	DO WHILE ( ASSOCIATED( p ) )
1709	q => p ; p => p%next ; DEALLOCATE(q)
1710	ENDDO
1711	NULLIFY(grid%head_statevars) ; NULLIFY( grid%tail_statevars)
1712	#if (DA_CORE != 1)
1713	IF ( .NOT. grid%is_intermediate ) THEN
1714	ALLOCATE( grid%head_statevars )
1715	NULLIFY( grid%head_statevars%next)
1716	grid%tail_statevars => grid%head_statevars
1717	ENDIF
1718	#endif
1719	END SUBROUTINE dealloc_linked_lists
1720
1721	RECURSIVE SUBROUTINE show_nest_subtree ( grid )
1722	TYPE(domain), POINTER :: grid
1723	INTEGER myid
1724	INTEGER kid
1725	IF ( .NOT. ASSOCIATED( grid ) ) RETURN
1726	myid = grid%id
1727	DO kid = 1, max_nests
1728	IF ( ASSOCIATED( grid%nests(kid)%ptr ) ) THEN
1729	IF ( grid%nests(kid)%ptr%id .EQ. myid ) THEN
1730	CALL wrf_error_fatal( 'show_nest_subtree: nest hierarchy corrupted' )
1731	ENDIF
1732	CALL show_nest_subtree( grid%nests(kid)%ptr )
1733	ENDIF
1734	ENDDO
1735	END SUBROUTINE show_nest_subtree
1736
1737
1738	!
1739
1740	! This routine DEALLOCATEs each gridded field for this domain. For each type of
1741	! different array (1d, 2d, 3d, etc.), the space for each pointer is DEALLOCATEd
1742	! for every -1 (i.e., each different meteorological field).
1743
1744	SUBROUTINE dealloc_space_field ( grid )
1745
1746	IMPLICIT NONE
1747
1748	! Input data.
1749
1750	TYPE(domain) , POINTER :: grid
1751
1752	! Local data.
1753
1754	INTEGER :: ierr
1755
1756	# include <deallocs.inc>
1757
1758	END SUBROUTINE dealloc_space_field
1759
1760	!
1761	!
1762	RECURSIVE SUBROUTINE find_grid_by_id ( id, in_grid, result_grid )
1763	IMPLICIT NONE
1764	INTEGER, INTENT(IN) :: id
1765	TYPE(domain), POINTER :: in_grid
1766	TYPE(domain), POINTER :: result_grid
1767	! <DESCRIPTION>
1768	! This is a recursive subroutine that traverses the domain hierarchy rooted
1769	! at the input argument <em>in_grid</em>, a pointer to TYPE(domain), and returns
1770	! a pointer to the domain matching the integer argument <em>id</em> if it exists.
1771	!
1772	! </DESCRIPTION>
1773	TYPE(domain), POINTER :: grid_ptr
1774	INTEGER :: kid
1775	LOGICAL :: found
1776	found = .FALSE.
1777	NULLIFY(result_grid)
1778	IF ( ASSOCIATED( in_grid ) ) THEN
1779	IF ( in_grid%id .EQ. id ) THEN
1780	result_grid => in_grid
1781	ELSE
1782	grid_ptr => in_grid
1783	DO WHILE ( ASSOCIATED( grid_ptr ) .AND. .NOT. found )
1784	DO kid = 1, max_nests
1785	IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) .AND. .NOT. found ) THEN
1786	CALL find_grid_by_id ( id, grid_ptr%nests(kid)%ptr, result_grid )
1787	IF ( ASSOCIATED( result_grid ) ) THEN
1788	IF ( result_grid%id .EQ. id ) found = .TRUE.
1789	ENDIF
1790	ENDIF
1791	ENDDO
1792	IF ( .NOT. found ) grid_ptr => grid_ptr%sibling
1793	ENDDO
1794	ENDIF
1795	ENDIF
1796	RETURN
1797	END SUBROUTINE find_grid_by_id
1798
1799
1800	FUNCTION first_loc_integer ( array , search ) RESULT ( loc )
1801
1802	IMPLICIT NONE
1803
1804	! Input data.
1805
1806	INTEGER , INTENT(IN) , DIMENSION(:) :: array
1807	INTEGER , INTENT(IN) :: search
1808
1809	! Output data.
1810
1811	INTEGER :: loc
1812
1813	!<DESCRIPTION>
1814	! This routine is used to find a specific domain identifier in an array
1815	! of domain identifiers.
1816	!
1817	!</DESCRIPTION>
1818
1819	! Local data.
1820
1821	INTEGER :: loop
1822
1823	loc = -1
1824	find : DO loop = 1 , SIZE(array)
1825	IF ( search == array(loop) ) THEN
1826	loc = loop
1827	EXIT find
1828	END IF
1829	END DO find
1830
1831	END FUNCTION first_loc_integer
1832	!
1833	SUBROUTINE init_module_domain
1834	END SUBROUTINE init_module_domain
1835
1836
1837	! <DESCRIPTION>
1838	!
1839	! The following routines named domain_*() are convenience routines that
1840	! eliminate many duplicated bits of code. They provide shortcuts for the
1841	! most common operations on the domain_clock field of TYPE(domain).
1842	!
1843	! </DESCRIPTION>
1844
1845	FUNCTION domain_get_current_time ( grid ) RESULT ( current_time )
1846	IMPLICIT NONE
1847	! <DESCRIPTION>
1848	! This convenience function returns the current time for domain grid.
1849	!
1850	! </DESCRIPTION>
1851	TYPE(domain), INTENT(IN) :: grid
1852	! result
1853	TYPE(WRFU_Time) :: current_time
1854	! locals
1855	INTEGER :: rc
1856	CALL WRFU_ClockGet( grid%domain_clock, CurrTime=current_time, &
1857	rc=rc )
1858	IF ( rc /= WRFU_SUCCESS ) THEN
1859	CALL wrf_error_fatal ( &
1860	'domain_get_current_time: WRFU_ClockGet failed' )
1861	ENDIF
1862	END FUNCTION domain_get_current_time
1863
1864
1865	FUNCTION domain_get_start_time ( grid ) RESULT ( start_time )
1866	IMPLICIT NONE
1867	! <DESCRIPTION>
1868	! This convenience function returns the start time for domain grid.
1869	!
1870	! </DESCRIPTION>
1871	TYPE(domain), INTENT(IN) :: grid
1872	! result
1873	TYPE(WRFU_Time) :: start_time
1874	! locals
1875	INTEGER :: rc
1876	CALL WRFU_ClockGet( grid%domain_clock, StartTime=start_time, &
1877	rc=rc )
1878	IF ( rc /= WRFU_SUCCESS ) THEN
1879	CALL wrf_error_fatal ( &
1880	'domain_get_start_time: WRFU_ClockGet failed' )
1881	ENDIF
1882	END FUNCTION domain_get_start_time
1883
1884
1885	FUNCTION domain_get_stop_time ( grid ) RESULT ( stop_time )
1886	IMPLICIT NONE
1887	! <DESCRIPTION>
1888	! This convenience function returns the stop time for domain grid.
1889	!
1890	! </DESCRIPTION>
1891	TYPE(domain), INTENT(IN) :: grid
1892	! result
1893	TYPE(WRFU_Time) :: stop_time
1894	! locals
1895	INTEGER :: rc
1896	CALL WRFU_ClockGet( grid%domain_clock, StopTime=stop_time, &
1897	rc=rc )
1898	IF ( rc /= WRFU_SUCCESS ) THEN
1899	CALL wrf_error_fatal ( &
1900	'domain_get_stop_time: WRFU_ClockGet failed' )
1901	ENDIF
1902	END FUNCTION domain_get_stop_time
1903
1904
1905	FUNCTION domain_get_time_step ( grid ) RESULT ( time_step )
1906	IMPLICIT NONE
1907	! <DESCRIPTION>
1908	! This convenience function returns the time step for domain grid.
1909	!
1910	! </DESCRIPTION>
1911	TYPE(domain), INTENT(IN) :: grid
1912	! result
1913	TYPE(WRFU_TimeInterval) :: time_step
1914	! locals
1915	INTEGER :: rc
1916	CALL WRFU_ClockGet( grid%domain_clock, timeStep=time_step, &
1917	rc=rc )
1918	IF ( rc /= WRFU_SUCCESS ) THEN
1919	CALL wrf_error_fatal ( &
1920	'domain_get_time_step: WRFU_ClockGet failed' )
1921	ENDIF
1922	END FUNCTION domain_get_time_step
1923
1924
1925	FUNCTION domain_get_advanceCount ( grid ) RESULT ( advanceCount )
1926	IMPLICIT NONE
1927	! <DESCRIPTION>
1928	! This convenience function returns the time step for domain grid.
1929	! Also converts from INTEGER(WRFU_KIND_I8) to INTEGER.
1930	!
1931	! </DESCRIPTION>
1932	TYPE(domain), INTENT(IN) :: grid
1933	! result
1934	INTEGER :: advanceCount
1935	! locals
1936	INTEGER(WRFU_KIND_I8) :: advanceCountLcl
1937	INTEGER :: rc
1938	CALL WRFU_ClockGet( grid%domain_clock, &
1939	advanceCount=advanceCountLcl, &
1940	rc=rc )
1941	IF ( rc /= WRFU_SUCCESS ) THEN
1942	CALL wrf_error_fatal ( &
1943	'domain_get_advanceCount: WRFU_ClockGet failed' )
1944	ENDIF
1945	advanceCount = advanceCountLcl
1946	END FUNCTION domain_get_advanceCount
1947
1948
1949	SUBROUTINE domain_alarms_destroy ( grid )
1950	IMPLICIT NONE
1951	! <DESCRIPTION>
1952	! This convenience routine destroys and deallocates all alarms associated
1953	! with grid.
1954	!
1955	! </DESCRIPTION>
1956	TYPE(domain), INTENT(INOUT) :: grid
1957	! Local data.
1958	INTEGER :: alarmid
1959
1960	IF ( ASSOCIATED( grid%alarms ) .AND. &
1961	ASSOCIATED( grid%alarms_created ) ) THEN
1962	DO alarmid = 1, MAX_WRF_ALARMS
1963	IF ( grid%alarms_created( alarmid ) ) THEN
1964	CALL WRFU_AlarmDestroy( grid%alarms( alarmid ) )
1965	grid%alarms_created( alarmid ) = .FALSE.
1966	ENDIF
1967	ENDDO
1968	DEALLOCATE( grid%alarms )
1969	NULLIFY( grid%alarms )
1970	DEALLOCATE( grid%alarms_created )
1971	NULLIFY( grid%alarms_created )
1972	ENDIF
1973	END SUBROUTINE domain_alarms_destroy
1974
1975
1976	SUBROUTINE domain_clock_destroy ( grid )
1977	IMPLICIT NONE
1978	! <DESCRIPTION>
1979	! This convenience routine destroys and deallocates the domain clock.
1980	!
1981	! </DESCRIPTION>
1982	TYPE(domain), INTENT(INOUT) :: grid
1983	IF ( ASSOCIATED( grid%domain_clock ) ) THEN
1984	IF ( grid%domain_clock_created ) THEN
1985	CALL WRFU_ClockDestroy( grid%domain_clock )
1986	grid%domain_clock_created = .FALSE.
1987	ENDIF
1988	DEALLOCATE( grid%domain_clock )
1989	NULLIFY( grid%domain_clock )
1990	ENDIF
1991	END SUBROUTINE domain_clock_destroy
1992
1993
1994	FUNCTION domain_last_time_step ( grid ) RESULT ( LAST_TIME )
1995	IMPLICIT NONE
1996	! <DESCRIPTION>
1997	! This convenience function returns .TRUE. if this is the last time
1998	! step for domain grid. Thanks to Tom Black.
1999	!
2000	! </DESCRIPTION>
2001	TYPE(domain), INTENT(IN) :: grid
2002	! result
2003	LOGICAL :: LAST_TIME
2004	LAST_TIME = domain_get_stop_time( grid ) .EQ. &
2005	( domain_get_current_time( grid ) + &
2006	domain_get_time_step( grid ) )
2007	END FUNCTION domain_last_time_step
2008
2009
2010
2011	FUNCTION domain_clockisstoptime ( grid ) RESULT ( is_stop_time )
2012	IMPLICIT NONE
2013	! <DESCRIPTION>
2014	! This convenience function returns .TRUE. iff grid%clock has reached its
2015	! stop time.
2016	!
2017	! </DESCRIPTION>
2018	TYPE(domain), INTENT(IN) :: grid
2019	! result
2020	LOGICAL :: is_stop_time
2021	INTEGER :: rc
2022	is_stop_time = WRFU_ClockIsStopTime( grid%domain_clock , rc=rc )
2023	IF ( rc /= WRFU_SUCCESS ) THEN
2024	CALL wrf_error_fatal ( &
2025	'domain_clockisstoptime: WRFU_ClockIsStopTime() failed' )
2026	ENDIF
2027	END FUNCTION domain_clockisstoptime
2028
2029
2030
2031	FUNCTION domain_clockisstopsubtime ( grid ) RESULT ( is_stop_subtime )
2032	IMPLICIT NONE
2033	! <DESCRIPTION>
2034	! This convenience function returns .TRUE. iff grid%clock has reached its
2035	! grid%stop_subtime.
2036	!
2037	! </DESCRIPTION>
2038	TYPE(domain), INTENT(IN) :: grid
2039	! result
2040	LOGICAL :: is_stop_subtime
2041	INTEGER :: rc
2042	TYPE(WRFU_TimeInterval) :: timeStep
2043	TYPE(WRFU_Time) :: currentTime
2044	LOGICAL :: positive_timestep
2045	is_stop_subtime = .FALSE.
2046	CALL domain_clock_get( grid, time_step=timeStep, &
2047	current_time=currentTime )
2048	positive_timestep = ESMF_TimeIntervalIsPositive( timeStep )
2049	IF ( positive_timestep ) THEN
2050	! hack for bug in PGI 5.1-x
2051	! IF ( currentTime .GE. grid%stop_subtime ) THEN
2052	IF ( ESMF_TimeGE( currentTime, grid%stop_subtime ) ) THEN
2053	is_stop_subtime = .TRUE.
2054	ENDIF
2055	ELSE
2056	! hack for bug in PGI 5.1-x
2057	! IF ( currentTime .LE. grid%stop_subtime ) THEN
2058	IF ( ESMF_TimeLE( currentTime, grid%stop_subtime ) ) THEN
2059	is_stop_subtime = .TRUE.
2060	ENDIF
2061	ENDIF
2062	END FUNCTION domain_clockisstopsubtime
2063
2064
2065
2066
2067	FUNCTION domain_get_sim_start_time ( grid ) RESULT ( simulationStartTime )
2068	IMPLICIT NONE
2069	! <DESCRIPTION>
2070	! This convenience routine returns simulation start time for domain grid as
2071	! a time instant.
2072	!
2073	! If this is not a restart run, the start_time of head_grid%clock is returned
2074	! instead.
2075	!
2076	! Note that simulation start time remains constant through restarts while
2077	! the start_time of head_grid%clock always refers to the start time of the
2078	! current run (restart or otherwise).
2079	!
2080	! </DESCRIPTION>
2081	TYPE(domain), INTENT(IN) :: grid
2082	! result
2083	TYPE(WRFU_Time) :: simulationStartTime
2084	! Locals
2085	INTEGER :: rc
2086	INTEGER :: simulation_start_year, simulation_start_month, &
2087	simulation_start_day, simulation_start_hour , &
2088	simulation_start_minute, simulation_start_second
2089	CALL nl_get_simulation_start_year ( 1, simulation_start_year )
2090	CALL nl_get_simulation_start_month ( 1, simulation_start_month )
2091	CALL nl_get_simulation_start_day ( 1, simulation_start_day )
2092	CALL nl_get_simulation_start_hour ( 1, simulation_start_hour )
2093	CALL nl_get_simulation_start_minute ( 1, simulation_start_minute )
2094	CALL nl_get_simulation_start_second ( 1, simulation_start_second )
2095	CALL WRFU_TimeSet( simulationStartTime, &
2096	YY=simulation_start_year, &
2097	MM=simulation_start_month, &
2098	DD=simulation_start_day, &
2099	H=simulation_start_hour, &
2100	M=simulation_start_minute, &
2101	S=simulation_start_second, &
2102	rc=rc )
2103	IF ( rc /= WRFU_SUCCESS ) THEN
2104	CALL nl_get_start_year ( 1, simulation_start_year )
2105	CALL nl_get_start_month ( 1, simulation_start_month )
2106	CALL nl_get_start_day ( 1, simulation_start_day )
2107	CALL nl_get_start_hour ( 1, simulation_start_hour )
2108	CALL nl_get_start_minute ( 1, simulation_start_minute )
2109	CALL nl_get_start_second ( 1, simulation_start_second )
2110	CALL wrf_debug( 150, "WARNING: domain_get_sim_start_time using head_grid start time from namelist" )
2111	CALL WRFU_TimeSet( simulationStartTime, &
2112	YY=simulation_start_year, &
2113	MM=simulation_start_month, &
2114	DD=simulation_start_day, &
2115	H=simulation_start_hour, &
2116	M=simulation_start_minute, &
2117	S=simulation_start_second, &
2118	rc=rc )
2119	ENDIF
2120	RETURN
2121	END FUNCTION domain_get_sim_start_time
2122
2123	FUNCTION domain_get_time_since_sim_start ( grid ) RESULT ( time_since_sim_start )
2124	IMPLICIT NONE
2125	! <DESCRIPTION>
2126	! This convenience function returns the time elapsed since start of
2127	! simulation for domain grid.
2128	!
2129	! Note that simulation start time remains constant through restarts while
2130	! the start_time of grid%clock always refers to the start time of the
2131	! current run (restart or otherwise).
2132	!
2133	! </DESCRIPTION>
2134	TYPE(domain), INTENT(IN) :: grid
2135	! result
2136	TYPE(WRFU_TimeInterval) :: time_since_sim_start
2137	! locals
2138	TYPE(WRFU_Time) :: lcl_currtime, lcl_simstarttime
2139	lcl_simstarttime = domain_get_sim_start_time( grid )
2140	lcl_currtime = domain_get_current_time ( grid )
2141	time_since_sim_start = lcl_currtime - lcl_simstarttime
2142	END FUNCTION domain_get_time_since_sim_start
2143
2144
2145
2146
2147	SUBROUTINE domain_clock_get( grid, current_time, &
2148	current_timestr, &
2149	current_timestr_frac, &
2150	start_time, start_timestr, &
2151	stop_time, stop_timestr, &
2152	time_step, time_stepstr, &
2153	time_stepstr_frac, &
2154	advanceCount, &
2155	currentDayOfYearReal, &
2156	minutesSinceSimulationStart, &
2157	timeSinceSimulationStart, &
2158	simulationStartTime, &
2159	simulationStartTimeStr )
2160	IMPLICIT NONE
2161	TYPE(domain), INTENT(IN) :: grid
2162	TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: current_time
2163	CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: current_timestr
2164	CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: current_timestr_frac
2165	TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: start_time
2166	CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: start_timestr
2167	TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: stop_time
2168	CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: stop_timestr
2169	TYPE(WRFU_TimeInterval), INTENT( OUT), OPTIONAL :: time_step
2170	CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: time_stepstr
2171	CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: time_stepstr_frac
2172	INTEGER, INTENT( OUT), OPTIONAL :: advanceCount
2173	! currentDayOfYearReal = 0.0 at 0Z on 1 January, 0.5 at 12Z on
2174	! 1 January, etc.
2175	REAL, INTENT( OUT), OPTIONAL :: currentDayOfYearReal
2176	! Time at which simulation started. If this is not a restart run,
2177	! start_time is returned instead.
2178	TYPE(WRFU_Time), INTENT( OUT), OPTIONAL :: simulationStartTime
2179	CHARACTER (LEN=*), INTENT( OUT), OPTIONAL :: simulationStartTimeStr
2180	! time interval since start of simulation, includes effects of
2181	! restarting even when restart uses a different timestep
2182	TYPE(WRFU_TimeInterval), INTENT( OUT), OPTIONAL :: timeSinceSimulationStart
2183	! minutes since simulation start date
2184	REAL, INTENT( OUT), OPTIONAL :: minutesSinceSimulationStart
2185	! <DESCRIPTION>
2186	! This convenience routine returns clock information for domain grid in
2187	! various forms. The caller is responsible for ensuring that character
2188	! string actual arguments are big enough.
2189	!
2190	! </DESCRIPTION>
2191	! Locals
2192	TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime, lcl_starttime
2193	TYPE(WRFU_Time) :: lcl_simulationStartTime
2194	TYPE(WRFU_TimeInterval) :: lcl_time_step, lcl_timeSinceSimulationStart
2195	INTEGER :: days, seconds, Sn, Sd, rc
2196	CHARACTER (LEN=256) :: tmp_str
2197	CHARACTER (LEN=256) :: frac_str
2198	REAL(WRFU_KIND_R8) :: currentDayOfYearR8
2199	IF ( PRESENT( start_time ) ) THEN
2200	start_time = domain_get_start_time ( grid )
2201	ENDIF
2202	IF ( PRESENT( start_timestr ) ) THEN
2203	lcl_starttime = domain_get_start_time ( grid )
2204	CALL wrf_timetoa ( lcl_starttime, start_timestr )
2205	ENDIF
2206	IF ( PRESENT( time_step ) ) THEN
2207	time_step = domain_get_time_step ( grid )
2208	ENDIF
2209	IF ( PRESENT( time_stepstr ) ) THEN
2210	lcl_time_step = domain_get_time_step ( grid )
2211	CALL WRFU_TimeIntervalGet( lcl_time_step, &
2212	timeString=time_stepstr, rc=rc )
2213	IF ( rc /= WRFU_SUCCESS ) THEN
2214	CALL wrf_error_fatal ( &
2215	'domain_clock_get: WRFU_TimeIntervalGet() failed' )
2216	ENDIF
2217	ENDIF
2218	IF ( PRESENT( time_stepstr_frac ) ) THEN
2219	lcl_time_step = domain_get_time_step ( grid )
2220	CALL WRFU_TimeIntervalGet( lcl_time_step, timeString=tmp_str, &
2221	Sn=Sn, Sd=Sd, rc=rc )
2222	IF ( rc /= WRFU_SUCCESS ) THEN
2223	CALL wrf_error_fatal ( &
2224	'domain_clock_get: WRFU_TimeIntervalGet() failed' )
2225	ENDIF
2226	CALL fraction_to_string( Sn, Sd, frac_str )
2227	time_stepstr_frac = TRIM(tmp_str)//TRIM(frac_str)
2228	ENDIF
2229	IF ( PRESENT( advanceCount ) ) THEN
2230	advanceCount = domain_get_advanceCount ( grid )
2231	ENDIF
2232	! This duplication avoids assignment of time-manager objects
2233	! which works now in ESMF 2.2.0 but may not work in the future
2234	! if these objects become "deep". We have already been bitten
2235	! by this when the clock objects were changed from "shallow" to
2236	! "deep". Once again, adherence to orthodox canonical form by
2237	! ESMF would avoid all this crap.
2238	IF ( PRESENT( current_time ) ) THEN
2239	current_time = domain_get_current_time ( grid )
2240	ENDIF
2241	IF ( PRESENT( current_timestr ) ) THEN
2242	lcl_currtime = domain_get_current_time ( grid )
2243	CALL wrf_timetoa ( lcl_currtime, current_timestr )
2244	ENDIF
2245	! current time string including fractional part, if present
2246	IF ( PRESENT( current_timestr_frac ) ) THEN
2247	lcl_currtime = domain_get_current_time ( grid )
2248	CALL wrf_timetoa ( lcl_currtime, tmp_str )
2249	CALL WRFU_TimeGet( lcl_currtime, Sn=Sn, Sd=Sd, rc=rc )
2250	IF ( rc /= WRFU_SUCCESS ) THEN
2251	CALL wrf_error_fatal ( &
2252	'domain_clock_get: WRFU_TimeGet() failed' )
2253	ENDIF
2254	CALL fraction_to_string( Sn, Sd, frac_str )
2255	current_timestr_frac = TRIM(tmp_str)//TRIM(frac_str)
2256	ENDIF
2257	IF ( PRESENT( stop_time ) ) THEN
2258	stop_time = domain_get_stop_time ( grid )
2259	ENDIF
2260	IF ( PRESENT( stop_timestr ) ) THEN
2261	lcl_stoptime = domain_get_stop_time ( grid )
2262	CALL wrf_timetoa ( lcl_stoptime, stop_timestr )
2263	ENDIF
2264	IF ( PRESENT( currentDayOfYearReal ) ) THEN
2265	lcl_currtime = domain_get_current_time ( grid )
2266	CALL WRFU_TimeGet( lcl_currtime, dayOfYear_r8=currentDayOfYearR8, &
2267	rc=rc )
2268	IF ( rc /= WRFU_SUCCESS ) THEN
2269	CALL wrf_error_fatal ( &
2270	'domain_clock_get: WRFU_TimeGet(dayOfYear_r8) failed' )
2271	ENDIF
2272	currentDayOfYearReal = REAL( currentDayOfYearR8 ) - 1.0
2273	ENDIF
2274	IF ( PRESENT( simulationStartTime ) ) THEN
2275	simulationStartTime = domain_get_sim_start_time( grid )
2276	ENDIF
2277	IF ( PRESENT( simulationStartTimeStr ) ) THEN
2278	lcl_simulationStartTime = domain_get_sim_start_time( grid )
2279	CALL wrf_timetoa ( lcl_simulationStartTime, simulationStartTimeStr )
2280	ENDIF
2281	IF ( PRESENT( timeSinceSimulationStart ) ) THEN
2282	timeSinceSimulationStart = domain_get_time_since_sim_start( grid )
2283	ENDIF
2284	IF ( PRESENT( minutesSinceSimulationStart ) ) THEN
2285	lcl_timeSinceSimulationStart = domain_get_time_since_sim_start( grid )
2286	CALL WRFU_TimeIntervalGet( lcl_timeSinceSimulationStart, &
2287	D=days, S=seconds, Sn=Sn, Sd=Sd, rc=rc )
2288	IF ( rc /= WRFU_SUCCESS ) THEN
2289	CALL wrf_error_fatal ( &
2290	'domain_clock_get: WRFU_TimeIntervalGet() failed' )
2291	ENDIF
2292	! get rid of hard-coded constants
2293	minutesSinceSimulationStart = ( REAL( days ) * 24. * 60. ) + &
2294	( REAL( seconds ) / 60. )
2295	IF ( Sd /= 0 ) THEN
2296	minutesSinceSimulationStart = minutesSinceSimulationStart + &
2297	( ( REAL( Sn ) / REAL( Sd ) ) / 60. )
2298	ENDIF
2299	ENDIF
2300	RETURN
2301	END SUBROUTINE domain_clock_get
2302
2303	FUNCTION domain_clockisstarttime ( grid ) RESULT ( is_start_time )
2304	IMPLICIT NONE
2305	! <DESCRIPTION>
2306	! This convenience function returns .TRUE. iff grid%clock is at its
2307	! start time.
2308	!
2309	! </DESCRIPTION>
2310	TYPE(domain), INTENT(IN) :: grid
2311	! result
2312	LOGICAL :: is_start_time
2313	TYPE(WRFU_Time) :: start_time, current_time
2314	CALL domain_clock_get( grid, current_time=current_time, &
2315	start_time=start_time )
2316	is_start_time = ( current_time == start_time )
2317	END FUNCTION domain_clockisstarttime
2318
2319	FUNCTION domain_clockissimstarttime ( grid ) RESULT ( is_sim_start_time )
2320	IMPLICIT NONE
2321	! <DESCRIPTION>
2322	! This convenience function returns .TRUE. iff grid%clock is at the
2323	! simulation start time. (It returns .FALSE. during a restart run.)
2324	!
2325	! </DESCRIPTION>
2326	TYPE(domain), INTENT(IN) :: grid
2327	! result
2328	LOGICAL :: is_sim_start_time
2329	TYPE(WRFU_Time) :: simulationStartTime, current_time
2330	CALL domain_clock_get( grid, current_time=current_time, &
2331	simulationStartTime=simulationStartTime )
2332	is_sim_start_time = ( current_time == simulationStartTime )
2333	END FUNCTION domain_clockissimstarttime
2334
2335
2336
2337
2338	SUBROUTINE domain_clock_create( grid, StartTime, &
2339	StopTime, &
2340	TimeStep )
2341	IMPLICIT NONE
2342	TYPE(domain), INTENT(INOUT) :: grid
2343	TYPE(WRFU_Time), INTENT(IN ) :: StartTime
2344	TYPE(WRFU_Time), INTENT(IN ) :: StopTime
2345	TYPE(WRFU_TimeInterval), INTENT(IN ) :: TimeStep
2346	! <DESCRIPTION>
2347	! This convenience routine creates the domain_clock for domain grid and
2348	! sets associated flags.
2349	!
2350	! </DESCRIPTION>
2351	! Locals
2352	INTEGER :: rc
2353	grid%domain_clock = WRFU_ClockCreate( TimeStep= TimeStep, &
2354	StartTime=StartTime, &
2355	StopTime= StopTime, &
2356	rc=rc )
2357	IF ( rc /= WRFU_SUCCESS ) THEN
2358	CALL wrf_error_fatal ( &
2359	'domain_clock_create: WRFU_ClockCreate() failed' )
2360	ENDIF
2361	grid%domain_clock_created = .TRUE.
2362	RETURN
2363	END SUBROUTINE domain_clock_create
2364
2365
2366
2367	SUBROUTINE domain_alarm_create( grid, alarm_id, interval, &
2368	begin_time, end_time )
2369	USE module_utility
2370	IMPLICIT NONE
2371	TYPE(domain), POINTER :: grid
2372	INTEGER, INTENT(IN) :: alarm_id
2373	TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: interval
2374	TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: begin_time
2375	TYPE(WRFU_TimeInterval), INTENT(IN), OPTIONAL :: end_time
2376	! <DESCRIPTION>
2377	! This convenience routine creates alarm alarm_id for domain grid and
2378	! sets associated flags.
2379	!
2380	! </DESCRIPTION>
2381	! Locals
2382	INTEGER :: rc
2383	!$$$ TBH: Ideally, this could be simplified by passing all optional actual
2384	!$$$ TBH: args into AlarmCreate. However, since operations are performed on
2385	!$$$ TBH: the actual args in-place in the calls, they must be present for the
2386	!$$$ TBH: operations themselves to be defined. Grrr...
2387	LOGICAL :: interval_only, all_args, no_args
2388	TYPE(WRFU_Time) :: startTime
2389	interval_only = .FALSE.
2390	all_args = .FALSE.
2391	no_args = .FALSE.
2392	IF ( ( .NOT. PRESENT( begin_time ) ) .AND. &
2393	( .NOT. PRESENT( end_time ) ) .AND. &
2394	( PRESENT( interval ) ) ) THEN
2395	interval_only = .TRUE.
2396	ELSE IF ( ( .NOT. PRESENT( begin_time ) ) .AND. &
2397	( .NOT. PRESENT( end_time ) ) .AND. &
2398	( .NOT. PRESENT( interval ) ) ) THEN
2399	no_args = .TRUE.
2400	ELSE IF ( ( PRESENT( begin_time ) ) .AND. &
2401	( PRESENT( end_time ) ) .AND. &
2402	( PRESENT( interval ) ) ) THEN
2403	all_args = .TRUE.
2404	ELSE
2405	CALL wrf_error_fatal ( &
2406	'ERROR in domain_alarm_create: bad argument list' )
2407	ENDIF
2408	CALL domain_clock_get( grid, start_time=startTime )
2409	IF ( interval_only ) THEN
2410	grid%io_intervals( alarm_id ) = interval
2411	grid%alarms( alarm_id ) = &
2412	WRFU_AlarmCreate( clock=grid%domain_clock, &
2413	RingInterval=interval, &
2414	rc=rc )
2415	ELSE IF ( no_args ) THEN
2416	grid%alarms( alarm_id ) = &
2417	WRFU_AlarmCreate( clock=grid%domain_clock, &
2418	RingTime=startTime, &
2419	rc=rc )
2420	ELSE IF ( all_args ) THEN
2421	grid%io_intervals( alarm_id ) = interval
2422	grid%alarms( alarm_id ) = &
2423	WRFU_AlarmCreate( clock=grid%domain_clock, &
2424	RingTime=startTime + begin_time, &
2425	RingInterval=interval, &
2426	StopTime=startTime + end_time, &
2427	rc=rc )
2428	ENDIF
2429	IF ( rc /= WRFU_SUCCESS ) THEN
2430	CALL wrf_error_fatal ( &
2431	'domain_alarm_create: WRFU_AlarmCreate() failed' )
2432	ENDIF
2433	CALL WRFU_AlarmRingerOff( grid%alarms( alarm_id ) , rc=rc )
2434	IF ( rc /= WRFU_SUCCESS ) THEN
2435	CALL wrf_error_fatal ( &
2436	'domain_alarm_create: WRFU_AlarmRingerOff() failed' )
2437	ENDIF
2438	grid%alarms_created( alarm_id ) = .TRUE.
2439	END SUBROUTINE domain_alarm_create
2440
2441
2442
2443	SUBROUTINE domain_clock_set( grid, current_timestr, &
2444	stop_timestr, &
2445	time_step_seconds )
2446	IMPLICIT NONE
2447	TYPE(domain), INTENT(INOUT) :: grid
2448	CHARACTER (LEN=*), INTENT(IN ), OPTIONAL :: current_timestr
2449	CHARACTER (LEN=*), INTENT(IN ), OPTIONAL :: stop_timestr
2450	INTEGER, INTENT(IN ), OPTIONAL :: time_step_seconds
2451	! <DESCRIPTION>
2452	! This convenience routine sets clock information for domain grid.
2453	! The caller is responsible for ensuring that character string actual
2454	! arguments are big enough.
2455	!
2456	! </DESCRIPTION>
2457	! Locals
2458	TYPE(WRFU_Time) :: lcl_currtime, lcl_stoptime
2459	TYPE(WRFU_TimeInterval) :: tmpTimeInterval
2460	INTEGER :: rc
2461	IF ( PRESENT( current_timestr ) ) THEN
2462	CALL wrf_atotime( current_timestr(1:19), lcl_currtime )
2463	CALL WRFU_ClockSet( grid%domain_clock, currTime=lcl_currtime, &
2464	rc=rc )
2465	IF ( rc /= WRFU_SUCCESS ) THEN
2466	CALL wrf_error_fatal ( &
2467	'domain_clock_set: WRFU_ClockSet(CurrTime) failed' )
2468	ENDIF
2469	ENDIF
2470	IF ( PRESENT( stop_timestr ) ) THEN
2471	CALL wrf_atotime( stop_timestr(1:19), lcl_stoptime )
2472	CALL WRFU_ClockSet( grid%domain_clock, stopTime=lcl_stoptime, &
2473	rc=rc )
2474	IF ( rc /= WRFU_SUCCESS ) THEN
2475	CALL wrf_error_fatal ( &
2476	'domain_clock_set: WRFU_ClockSet(StopTime) failed' )
2477	ENDIF
2478	ENDIF
2479	IF ( PRESENT( time_step_seconds ) ) THEN
2480	CALL WRFU_TimeIntervalSet( tmpTimeInterval, &
2481	S=time_step_seconds, rc=rc )
2482	IF ( rc /= WRFU_SUCCESS ) THEN
2483	CALL wrf_error_fatal ( &
2484	'domain_clock_set: WRFU_TimeIntervalSet failed' )
2485	ENDIF
2486	CALL WRFU_ClockSet ( grid%domain_clock, &
2487	timeStep=tmpTimeInterval, &
2488	rc=rc )
2489	IF ( rc /= WRFU_SUCCESS ) THEN
2490	CALL wrf_error_fatal ( &
2491	'domain_clock_set: WRFU_ClockSet(TimeStep) failed' )
2492	ENDIF
2493	ENDIF
2494	RETURN
2495	END SUBROUTINE domain_clock_set
2496
2497
2498	! Debug routine to print key clock information.
2499	! Printed lines include pre_str.
2500	SUBROUTINE domain_clockprint ( level, grid, pre_str )
2501	IMPLICIT NONE
2502	INTEGER, INTENT( IN) :: level
2503	TYPE(domain), INTENT( IN) :: grid
2504	CHARACTER (LEN=*), INTENT( IN) :: pre_str
2505	CALL wrf_clockprint ( level, grid%domain_clock, pre_str )
2506	RETURN
2507	END SUBROUTINE domain_clockprint
2508
2509
2510	! Advance the clock associated with grid.
2511	! Also updates several derived time quantities in grid state.
2512	SUBROUTINE domain_clockadvance ( grid )
2513	IMPLICIT NONE
2514	TYPE(domain), INTENT(INOUT) :: grid
2515	INTEGER :: rc
2516	CALL domain_clockprint ( 250, grid, &
2517	'DEBUG domain_clockadvance(): before WRFU_ClockAdvance,' )
2518	CALL WRFU_ClockAdvance( grid%domain_clock, rc=rc )
2519	IF ( rc /= WRFU_SUCCESS ) THEN
2520	CALL wrf_error_fatal ( &
2521	'domain_clockadvance: WRFU_ClockAdvance() failed' )
2522	ENDIF
2523	CALL domain_clockprint ( 250, grid, &
2524	'DEBUG domain_clockadvance(): after WRFU_ClockAdvance,' )
2525	! Update derived time quantities in grid state.
2526	! These are initialized in setup_timekeeping().
2527	CALL domain_clock_get( grid, minutesSinceSimulationStart=grid%xtime )
2528	CALL domain_clock_get( grid, currentDayOfYearReal=grid%julian )
2529	RETURN
2530	END SUBROUTINE domain_clockadvance
2531
2532
2533
2534	! Set grid%gmt, grid%julday, and grid%julyr from simulation-start-date.
2535	! Set start_of_simulation to TRUE iff current_time == simulation_start_time
2536	SUBROUTINE domain_setgmtetc ( grid, start_of_simulation )
2537	IMPLICIT NONE
2538	TYPE (domain), INTENT(INOUT) :: grid
2539	LOGICAL, INTENT( OUT) :: start_of_simulation
2540	! locals
2541	CHARACTER (LEN=132) :: message
2542	TYPE(WRFU_Time) :: simStartTime
2543	INTEGER :: hr, mn, sec, ms, rc
2544	CALL domain_clockprint(150, grid, &
2545	'DEBUG domain_setgmtetc(): get simStartTime from clock,')
2546	CALL domain_clock_get( grid, simulationStartTime=simStartTime, &
2547	simulationStartTimeStr=message )
2548	CALL WRFU_TimeGet( simStartTime, YY=grid%julyr, dayOfYear=grid%julday, &
2549	H=hr, M=mn, S=sec, MS=ms, rc=rc)
2550	IF ( rc /= WRFU_SUCCESS ) THEN
2551	CALL wrf_error_fatal ( &
2552	'domain_setgmtetc: WRFU_TimeGet() failed' )
2553	ENDIF
2554	WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc(): simulation start time = [',TRIM( message ),']'
2555	CALL wrf_debug( 150, TRIM(wrf_err_message) )
2556	grid%gmt=hr+real(mn)/60.+real(sec)/3600.+real(ms)/(1000*3600)
2557	WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc(): julyr,hr,mn,sec,ms,julday = ', &
2558	grid%julyr,hr,mn,sec,ms,grid%julday
2559	CALL wrf_debug( 150, TRIM(wrf_err_message) )
2560	WRITE( wrf_err_message , * ) 'DEBUG domain_setgmtetc(): gmt = ',grid%gmt
2561	CALL wrf_debug( 150, TRIM(wrf_err_message) )
2562	start_of_simulation = domain_ClockIsSimStartTime(grid)
2563	RETURN
2564	END SUBROUTINE domain_setgmtetc
2565
2566
2567
2568	! Set pointer to current grid.
2569	! To begin with, current grid is not set.
2570	SUBROUTINE set_current_grid_ptr( grid_ptr )
2571	IMPLICIT NONE
2572	TYPE(domain), POINTER :: grid_ptr
2573	!PRINT *,'DEBUG: begin set_current_grid_ptr()'
2574	!IF ( ASSOCIATED( grid_ptr ) ) THEN
2575	! PRINT *,'DEBUG: set_current_grid_ptr(): current_grid is associated'
2576	!ELSE
2577	! PRINT *,'DEBUG: set_current_grid_ptr(): current_grid is NOT associated'
2578	!ENDIF
2579	current_grid_set = .TRUE.
2580	current_grid => grid_ptr
2581	!PRINT *,'DEBUG: end set_current_grid_ptr()'
2582	END SUBROUTINE set_current_grid_ptr
2583
2584
2585
2586	!******************************************************************************
2587	! From Uli Blahak (01 Dec 2006)
2588	! UB: Function to determine if the next time step is an alarm-timestep for a certain grid:
2589	!******************************************************************************
2590
2591	LOGICAL FUNCTION Is_alarm_tstep( grid_clock, alarm )
2592
2593	IMPLICIT NONE
2594
2595	TYPE (WRFU_Clock), INTENT(in) :: grid_clock
2596	TYPE (WRFU_Alarm), INTENT(in) :: alarm
2597
2598	LOGICAL :: pred1, pred2, pred3
2599
2600	Is_alarm_tstep = .FALSE.
2601
2602	IF ( ASSOCIATED( alarm%alarmint ) ) THEN
2603	IF ( alarm%alarmint%Enabled ) THEN
2604	IF ( alarm%alarmint%RingIntervalSet ) THEN
2605	pred1 = .FALSE. ; pred2 = .FALSE. ; pred3 = .FALSE.
2606	IF ( alarm%alarmint%StopTimeSet ) THEN
2607	PRED1 = ( grid_clock%clockint%CurrTime + grid_clock%clockint%TimeStep > &
2608	alarm%alarmint%StopTime )
2609	ENDIF
2610	IF ( alarm%alarmint%RingTimeSet ) THEN
2611	PRED2 = ( ( alarm%alarmint%RingTime - &
2612	grid_clock%clockint%TimeStep <= &
2613	grid_clock%clockint%CurrTime ) &
2614	.AND. ( grid_clock%clockint%CurrTime < alarm%alarmint%RingTime ) )
2615	ENDIF
2616	IF ( alarm%alarmint%RingIntervalSet ) THEN
2617	PRED3 = ( alarm%alarmint%PrevRingTime + &
2618	alarm%alarmint%RingInterval <= &
2619	grid_clock%clockint%CurrTime + grid_clock%clockint%TimeStep )
2620	ENDIF
2621	IF ( ( .NOT. ( pred1 ) ) .AND. &
2622	( ( pred2 ) .OR. ( pred3 ) ) ) THEN
2623	Is_alarm_tstep = .TRUE.
2624	ENDIF
2625	ELSE IF ( alarm%alarmint%RingTimeSet ) THEN
2626	IF ( alarm%alarmint%RingTime -&
2627	grid_clock%clockint%TimeStep <= &
2628	grid_clock%clockint%CurrTime ) THEN
2629	Is_alarm_tstep = .TRUE.
2630	ENDIF
2631	ENDIF
2632	ENDIF
2633	ENDIF
2634
2635	END FUNCTION Is_alarm_tstep
2636
2637
2638	#if (NMM_CORE==1)
2639	!******************************************************************************
2640	! Function to determine if the next NPHS time step is an alarm-timestep for
2641	! a certain grid:
2642	! NMM-only -- modify to check whether the next alarm coincides with the next
2643	! NPHS time step!
2644	!******************************************************************************
2645
2646	LOGICAL FUNCTION Is_alarm_tstep_nphs( grid_clock, alarm, nphs )
2647
2648	IMPLICIT NONE
2649
2650	TYPE (WRFU_Clock), INTENT(in) :: grid_clock
2651	TYPE (WRFU_Alarm), INTENT(in) :: alarm
2652
2653	LOGICAL :: pred1, pred2, pred3
2654	INTEGER :: nphs
2655
2656	Is_alarm_tstep_nphs = .FALSE.
2657
2658	IF ( ASSOCIATED( alarm%alarmint ) ) THEN
2659	IF ( alarm%alarmint%Enabled ) THEN
2660	IF ( alarm%alarmint%RingIntervalSet ) THEN
2661	pred1 = .FALSE. ; pred2 = .FALSE. ; pred3 = .FALSE.
2662	IF ( alarm%alarmint%StopTimeSet ) THEN
2663	PRED1 = ( grid_clock%clockint%CurrTime + grid_clock%clockint%TimeStep*nphs > &
2664	alarm%alarmint%StopTime )
2665	ENDIF
2666	IF ( alarm%alarmint%RingTimeSet ) THEN
2667	PRED2 = ( ( alarm%alarmint%RingTime - &
2668	grid_clock%clockint%TimeStep <= &
2669	grid_clock%clockint%CurrTime ) &
2670	.AND. ( grid_clock%clockint%CurrTime < alarm%alarmint%RingTime ) )
2671	ENDIF
2672	IF ( alarm%alarmint%RingIntervalSet ) THEN
2673	PRED3 = ( alarm%alarmint%PrevRingTime + &
2674	alarm%alarmint%RingInterval <= &
2675	grid_clock%clockint%CurrTime + grid_clock%clockint%TimeStep*nphs )
2676	ENDIF
2677	IF ( ( .NOT. ( pred1 ) ) .AND. &
2678	( ( pred2 ) .OR. ( pred3 ) ) ) THEN
2679	Is_alarm_tstep_nphs = .TRUE.
2680	ENDIF
2681	ELSE IF ( alarm%alarmint%RingTimeSet ) THEN
2682	IF ( alarm%alarmint%RingTime -&
2683	grid_clock%clockint%TimeStep*nphs <= &
2684	grid_clock%clockint%CurrTime ) THEN
2685	Is_alarm_tstep_nphs = .TRUE.
2686	ENDIF
2687	ENDIF
2688	ENDIF
2689	ENDIF
2690
2691	END FUNCTION Is_alarm_tstep_nphs
2692	#endif
2693
2694
2695	!******************************************************************************
2696	! BEGIN TEST SECTION
2697	! Code in the test section is used to test domain methods.
2698	! This code should probably be moved elsewhere, eventually.
2699	!******************************************************************************
2700
2701	! Private utility routines for domain_time_test.
2702	SUBROUTINE domain_time_test_print ( pre_str, name_str, res_str )
2703	IMPLICIT NONE
2704	CHARACTER (LEN=*), INTENT(IN) :: pre_str
2705	CHARACTER (LEN=*), INTENT(IN) :: name_str
2706	CHARACTER (LEN=*), INTENT(IN) :: res_str
2707	CHARACTER (LEN=512) :: out_str
2708	WRITE (out_str, &
2709	FMT="('DOMAIN_TIME_TEST ',A,': ',A,' = ',A)") &
2710	TRIM(pre_str), TRIM(name_str), TRIM(res_str)
2711	CALL wrf_debug( 0, TRIM(out_str) )
2712	END SUBROUTINE domain_time_test_print
2713
2714	! Test adjust_io_timestr
2715	SUBROUTINE test_adjust_io_timestr( TI_h, TI_m, TI_s, &
2716	CT_yy, CT_mm, CT_dd, CT_h, CT_m, CT_s, &
2717	ST_yy, ST_mm, ST_dd, ST_h, ST_m, ST_s, &
2718	res_str, testname )
2719	INTEGER, INTENT(IN) :: TI_H
2720	INTEGER, INTENT(IN) :: TI_M
2721	INTEGER, INTENT(IN) :: TI_S
2722	INTEGER, INTENT(IN) :: CT_YY
2723	INTEGER, INTENT(IN) :: CT_MM ! month
2724	INTEGER, INTENT(IN) :: CT_DD ! day of month
2725	INTEGER, INTENT(IN) :: CT_H
2726	INTEGER, INTENT(IN) :: CT_M
2727	INTEGER, INTENT(IN) :: CT_S
2728	INTEGER, INTENT(IN) :: ST_YY
2729	INTEGER, INTENT(IN) :: ST_MM ! month
2730	INTEGER, INTENT(IN) :: ST_DD ! day of month
2731	INTEGER, INTENT(IN) :: ST_H
2732	INTEGER, INTENT(IN) :: ST_M
2733	INTEGER, INTENT(IN) :: ST_S
2734	CHARACTER (LEN=*), INTENT(IN) :: res_str
2735	CHARACTER (LEN=*), INTENT(IN) :: testname
2736	! locals
2737	TYPE(WRFU_TimeInterval) :: TI
2738	TYPE(WRFU_Time) :: CT, ST
2739	LOGICAL :: test_passed
2740	INTEGER :: rc
2741	CHARACTER(LEN=WRFU_MAXSTR) :: TI_str, CT_str, ST_str, computed_str
2742	! TI
2743	CALL WRFU_TimeIntervalSet( TI, H=TI_H, M=TI_M, S=TI_S, rc=rc )
2744	CALL wrf_check_error( WRFU_SUCCESS, rc, &
2745	'FAIL: '//TRIM(testname)//'WRFU_TimeIntervalSet() ', &
2746	__FILE__ , &
2747	__LINE__ )
2748	CALL WRFU_TimeIntervalGet( TI, timeString=TI_str, rc=rc )
2749	CALL wrf_check_error( WRFU_SUCCESS, rc, &
2750	'FAIL: '//TRIM(testname)//'WRFU_TimeGet() ', &
2751	__FILE__ , &
2752	__LINE__ )
2753	! CT
2754	CALL WRFU_TimeSet( CT, YY=CT_YY, MM=CT_MM, DD=CT_DD , &
2755	H=CT_H, M=CT_M, S=CT_S, rc=rc )
2756	CALL wrf_check_error( WRFU_SUCCESS, rc, &
2757	'FAIL: '//TRIM(testname)//'WRFU_TimeSet() ', &
2758	__FILE__ , &
2759	__LINE__ )
2760	CALL WRFU_TimeGet( CT, timeString=CT_str, rc=rc )
2761	CALL wrf_check_error( WRFU_SUCCESS, rc, &
2762	'FAIL: '//TRIM(testname)//'WRFU_TimeGet() ', &
2763	__FILE__ , &
2764	__LINE__ )
2765	! ST
2766	CALL WRFU_TimeSet( ST, YY=ST_YY, MM=ST_MM, DD=ST_DD , &
2767	H=ST_H, M=ST_M, S=ST_S, rc=rc )
2768	CALL wrf_check_error( WRFU_SUCCESS, rc, &
2769	'FAIL: '//TRIM(testname)//'WRFU_TimeSet() ', &
2770	__FILE__ , &
2771	__LINE__ )
2772	CALL WRFU_TimeGet( ST, timeString=ST_str, rc=rc )
2773	CALL wrf_check_error( WRFU_SUCCESS, rc, &
2774	'FAIL: '//TRIM(testname)//'WRFU_TimeGet() ', &
2775	__FILE__ , &
2776	__LINE__ )
2777	! Test
2778	CALL adjust_io_timestr ( TI, CT, ST, computed_str )
2779	! check result
2780	test_passed = .FALSE.
2781	IF ( LEN_TRIM(res_str) == LEN_TRIM(computed_str) ) THEN
2782	IF ( res_str(1:LEN_TRIM(res_str)) == computed_str(1:LEN_TRIM(computed_str)) ) THEN
2783	test_passed = .TRUE.
2784	ENDIF
2785	ENDIF
2786	! print result
2787	IF ( test_passed ) THEN
2788	WRITE(*,FMT='(A)') 'PASS: '//TRIM(testname)
2789	ELSE
2790	WRITE(,) 'FAIL: ',TRIM(testname),': adjust_io_timestr(', &
2791	TRIM(TI_str),',',TRIM(CT_str),',',TRIM(ST_str),') expected <', &
2792	TRIM(res_str),'> but computed <',TRIM(computed_str),'>'
2793	ENDIF
2794	END SUBROUTINE test_adjust_io_timestr
2795
2796	! Print lots of time-related information for testing and debugging.
2797	! Printed lines include pre_str and special string DOMAIN_TIME_TEST
2798	! suitable for grepping by test scripts.
2799	! Returns immediately unless self_test_domain has been set to .true. in
2800	! namelist /time_control/ .
2801	SUBROUTINE domain_time_test ( grid, pre_str )
2802	IMPLICIT NONE
2803	TYPE(domain), INTENT(IN) :: grid
2804	CHARACTER (LEN=*), INTENT(IN) :: pre_str
2805	! locals
2806	LOGICAL, SAVE :: one_time_tests_done = .FALSE.
2807	REAL :: minutesSinceSimulationStart
2808	INTEGER :: advance_count, rc
2809	REAL :: currentDayOfYearReal
2810	TYPE(WRFU_TimeInterval) :: timeSinceSimulationStart
2811	TYPE(WRFU_Time) :: simulationStartTime
2812	CHARACTER (LEN=512) :: res_str
2813	LOGICAL :: self_test_domain
2814	!
2815	! NOTE: test_adjust_io_timestr() (see below) is a self-test that
2816	! prints PASS/FAIL/ERROR messages in a standard format. All
2817	! of the other tests should be strucutred the same way,
2818	! someday.
2819	!
2820	CALL nl_get_self_test_domain( 1, self_test_domain )
2821	IF ( self_test_domain ) THEN
2822	CALL domain_clock_get( grid, advanceCount=advance_count )
2823	WRITE ( res_str, FMT="(I8.8)" ) advance_count
2824	CALL domain_time_test_print( pre_str, 'advanceCount', res_str )
2825	CALL domain_clock_get( grid, currentDayOfYearReal=currentDayOfYearReal )
2826	WRITE ( res_str, FMT='(F10.6)' ) currentDayOfYearReal
2827	CALL domain_time_test_print( pre_str, 'currentDayOfYearReal', res_str )
2828	CALL domain_clock_get( grid, minutesSinceSimulationStart=minutesSinceSimulationStart )
2829	WRITE ( res_str, FMT='(F10.6)' ) minutesSinceSimulationStart
2830	CALL domain_time_test_print( pre_str, 'minutesSinceSimulationStart', res_str )
2831	CALL domain_clock_get( grid, current_timestr=res_str )
2832	CALL domain_time_test_print( pre_str, 'current_timestr', res_str )
2833	CALL domain_clock_get( grid, current_timestr_frac=res_str )
2834	CALL domain_time_test_print( pre_str, 'current_timestr_frac', res_str )
2835	CALL domain_clock_get( grid, timeSinceSimulationStart=timeSinceSimulationStart )
2836	CALL WRFU_TimeIntervalGet( timeSinceSimulationStart, timeString=res_str, rc=rc )
2837	IF ( rc /= WRFU_SUCCESS ) THEN
2838	CALL wrf_error_fatal ( &
2839	'domain_time_test: WRFU_TimeIntervalGet() failed' )
2840	ENDIF
2841	CALL domain_time_test_print( pre_str, 'timeSinceSimulationStart', res_str )
2842	! The following tests should only be done once, the first time this
2843	! routine is called.
2844	IF ( .NOT. one_time_tests_done ) THEN
2845	one_time_tests_done = .TRUE.
2846	CALL domain_clock_get( grid, simulationStartTimeStr=res_str )
2847	CALL domain_time_test_print( pre_str, 'simulationStartTime', res_str )
2848	CALL domain_clock_get( grid, start_timestr=res_str )
2849	CALL domain_time_test_print( pre_str, 'start_timestr', res_str )
2850	CALL domain_clock_get( grid, stop_timestr=res_str )
2851	CALL domain_time_test_print( pre_str, 'stop_timestr', res_str )
2852	CALL domain_clock_get( grid, time_stepstr=res_str )
2853	CALL domain_time_test_print( pre_str, 'time_stepstr', res_str )
2854	CALL domain_clock_get( grid, time_stepstr_frac=res_str )
2855	CALL domain_time_test_print( pre_str, 'time_stepstr_frac', res_str )
2856	! Test adjust_io_timestr()
2857	! CT = 2000-01-26_00:00:00 (current time)
2858	! ST = 2000-01-24_12:00:00 (start time)
2859	! TI = 00000_03:00:00 (time interval)
2860	! the resulting time string should be:
2861	! 2000-01-26_00:00:00
2862	CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0, &
2863	CT_yy=2000, CT_mm=1, CT_dd=26, CT_h=0, CT_m=0, CT_s=0, &
2864	ST_yy=2000, ST_mm=1, ST_dd=24, ST_h=12, ST_m=0, ST_s=0, &
2865	res_str='2000-01-26_00:00:00', testname='adjust_io_timestr_1' )
2866	! this should fail (and does)
2867	! CALL test_adjust_io_timestr( TI_h=3, TI_m=0, TI_s=0, &
2868	! CT_yy=2000, CT_mm=1, CT_dd=26, CT_h=0, CT_m=0, CT_s=0, &
2869	! ST_yy=2000, ST_mm=1, ST_dd=24, ST_h=12, ST_m=0, ST_s=0, &
2870	! res_str='2000-01-26_00:00:01', testname='adjust_io_timestr_FAIL1' )
2871	ENDIF
2872	ENDIF
2873	RETURN
2874	END SUBROUTINE domain_time_test
2875
2876	!******************************************************************************
2877	! END TEST SECTION
2878	!******************************************************************************
2879
2880
2881	END MODULE module_domain
2882
2883
2884	! The following routines are outside this module to avoid build dependences.
2885
2886
2887	! Get current time as a string (current time from clock attached to the
2888	! current_grid). Includes fractional part, if present.
2889	! Returns empty string if current_grid is not set or if timing has not yet
2890	! been set up on current_grid.
2891	SUBROUTINE get_current_time_string( time_str )
2892	USE module_domain
2893	IMPLICIT NONE
2894	CHARACTER (LEN=*), INTENT(OUT) :: time_str
2895	! locals
2896	INTEGER :: debug_level_lcl
2897	!PRINT *,'DEBUG: begin get_current_time_string()'
2898	time_str = ''
2899	IF ( current_grid_set ) THEN
2900	!$$$DEBUG
2901	!PRINT *,'DEBUG: get_current_time_string(): checking association of current_grid...'
2902	!IF ( ASSOCIATED( current_grid ) ) THEN
2903	! PRINT *,'DEBUG: get_current_time_string(): current_grid is associated'
2904	!ELSE
2905	! PRINT *,'DEBUG: get_current_time_string(): current_grid is NOT associated'
2906	!ENDIF
2907	!$$$END DEBUG
2908	IF ( current_grid%time_set ) THEN
2909	!PRINT *,'DEBUG: get_current_time_string(): calling domain_clock_get()'
2910	! set debug_level to zero and clear current_grid_set to avoid recursion
2911	CALL get_wrf_debug_level( debug_level_lcl )
2912	CALL set_wrf_debug_level ( 0 )
2913	current_grid_set = .FALSE.
2914	CALL domain_clock_get( current_grid, current_timestr_frac=time_str )
2915	! restore debug_level and current_grid_set
2916	CALL set_wrf_debug_level ( debug_level_lcl )
2917	current_grid_set = .TRUE.
2918	!PRINT *,'DEBUG: get_current_time_string(): back from domain_clock_get()'
2919	ENDIF
2920	ENDIF
2921	!PRINT *,'DEBUG: end get_current_time_string()'
2922	END SUBROUTINE get_current_time_string
2923
2924
2925	! Get current domain name as a string of form "d<NN>" where "<NN>" is
2926	! grid%id printed in two characters, with leading zero if needed ("d01",
2927	! "d02", etc.).
2928	! Return empty string if current_grid not set.
2929	SUBROUTINE get_current_grid_name( grid_str )
2930	USE module_domain
2931	IMPLICIT NONE
2932	CHARACTER (LEN=*), INTENT(OUT) :: grid_str
2933	grid_str = ''
2934	IF ( current_grid_set ) THEN
2935	WRITE(grid_str,FMT="('d',I2.2)") current_grid%id
2936	ENDIF
2937	END SUBROUTINE get_current_grid_name
2938
2939
2940	! moved these outside module domain to avoid circular reference from module_alloc_space which also uses
2941
2942	SUBROUTINE get_ijk_from_grid_ext ( grid , &
2943	ids, ide, jds, jde, kds, kde, &
2944	ims, ime, jms, jme, kms, kme, &
2945	ips, ipe, jps, jpe, kps, kpe, &
2946	imsx, imex, jmsx, jmex, kmsx, kmex, &
2947	ipsx, ipex, jpsx, jpex, kpsx, kpex, &
2948	imsy, imey, jmsy, jmey, kmsy, kmey, &
2949	ipsy, ipey, jpsy, jpey, kpsy, kpey )
2950	USE module_domain
2951	IMPLICIT NONE
2952	TYPE( domain ), INTENT (IN) :: grid
2953	INTEGER, INTENT(OUT) :: &
2954	ids, ide, jds, jde, kds, kde, &
2955	ims, ime, jms, jme, kms, kme, &
2956	ips, ipe, jps, jpe, kps, kpe, &
2957	imsx, imex, jmsx, jmex, kmsx, kmex, &
2958	ipsx, ipex, jpsx, jpex, kpsx, kpex, &
2959	imsy, imey, jmsy, jmey, kmsy, kmey, &
2960	ipsy, ipey, jpsy, jpey, kpsy, kpey
2961
2962	CALL get_ijk_from_grid2 ( grid , &
2963	ids, ide, jds, jde, kds, kde, &
2964	ims, ime, jms, jme, kms, kme, &
2965	ips, ipe, jps, jpe, kps, kpe )
2966	data_ordering : SELECT CASE ( model_data_order )
2967	CASE ( DATA_ORDER_XYZ )
2968	imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
2969	ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
2970	imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
2971	ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
2972	CASE ( DATA_ORDER_YXZ )
2973	imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ;
2974	ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ;
2975	imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ;
2976	ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ;
2977	CASE ( DATA_ORDER_ZXY )
2978	imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
2979	ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
2980	imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
2981	ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
2982	CASE ( DATA_ORDER_ZYX )
2983	imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ;
2984	ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ;
2985	imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ;
2986	ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ;
2987	CASE ( DATA_ORDER_XZY )
2988	imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
2989	ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
2990	imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
2991	ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
2992	CASE ( DATA_ORDER_YZX )
2993	imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ;
2994	ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ;
2995	imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ;
2996	ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ;
2997	END SELECT data_ordering
2998	END SUBROUTINE get_ijk_from_grid_ext
2999
3000	! return the values for subgrid whose refinement is in grid%sr
3001	! note when using this routine, it does not affect K. For K
3002	! (vertical), it just returns what get_ijk_from_grid does
3003	SUBROUTINE get_ijk_from_subgrid_ext ( grid , &
3004	ids0, ide0, jds0, jde0, kds0, kde0, &
3005	ims0, ime0, jms0, jme0, kms0, kme0, &
3006	ips0, ipe0, jps0, jpe0, kps0, kpe0 )
3007	USE module_domain
3008	IMPLICIT NONE
3009	TYPE( domain ), INTENT (IN) :: grid
3010	INTEGER, INTENT(OUT) :: &
3011	ids0, ide0, jds0, jde0, kds0, kde0, &
3012	ims0, ime0, jms0, jme0, kms0, kme0, &
3013	ips0, ipe0, jps0, jpe0, kps0, kpe0
3014	! Local
3015	INTEGER :: &
3016	ids, ide, jds, jde, kds, kde, &
3017	ims, ime, jms, jme, kms, kme, &
3018	ips, ipe, jps, jpe, kps, kpe
3019	CALL get_ijk_from_grid ( grid , &
3020	ids, ide, jds, jde, kds, kde, &
3021	ims, ime, jms, jme, kms, kme, &
3022	ips, ipe, jps, jpe, kps, kpe )
3023	ids0 = ids
3024	ide0 = ide * grid%sr_x
3025	ims0 = (ims-1)*grid%sr_x+1
3026	ime0 = ime * grid%sr_x
3027	ips0 = (ips-1)*grid%sr_x+1
3028	ipe0 = ipe * grid%sr_x
3029
3030	jds0 = jds
3031	jde0 = jde * grid%sr_y
3032	jms0 = (jms-1)*grid%sr_y+1
3033	jme0 = jme * grid%sr_y
3034	jps0 = (jps-1)*grid%sr_y+1
3035	jpe0 = jpe * grid%sr_y
3036
3037	kds0 = kds
3038	kde0 = kde
3039	kms0 = kms
3040	kme0 = kme
3041	kps0 = kps
3042	kpe0 = kpe
3043	RETURN
3044	END SUBROUTINE get_ijk_from_subgrid_ext
3045
3046	! find the grid based on the id reference and return that
3047	SUBROUTINE get_dims_from_grid_id ( id &
3048	,ds, de &
3049	,ms, me &
3050	,ps, pe &
3051	,mxs, mxe &
3052	,pxs, pxe &
3053	,mys, mye &
3054	,pys, pye )
3055	USE module_domain, ONLY : domain, head_grid, find_grid_by_id
3056	IMPLICIT NONE
3057	TYPE( domain ), POINTER :: grid
3058	INTEGER, INTENT(IN ) :: id
3059	INTEGER, DIMENSION(3), INTENT(INOUT) :: &
3060	ds, de &
3061	,ms, me &
3062	,ps, pe &
3063	,mxs, mxe &
3064	,pxs, pxe &
3065	,mys, mye &
3066	,pys, pye
3067
3068	!local
3069	CHARACTER*256 mess
3070
3071	NULLIFY( grid )
3072	CALL find_grid_by_id ( id, head_grid, grid )
3073
3074	IF ( ASSOCIATED(grid) ) THEN
3075	ds(1) = grid%sd31 ; de(1) = grid%ed31 ; ds(2) = grid%sd32 ; de(2) = grid%ed32 ; ds(3) = grid%sd33 ; de(3) = grid%ed33 ;
3076	ms(1) = grid%sm31 ; me(1) = grid%em31 ; ms(2) = grid%sm32 ; me(2) = grid%em32 ; ms(3) = grid%sm33 ; me(3) = grid%em33 ;
3077	ps(1) = grid%sp31 ; pe(1) = grid%ep31 ; ps(2) = grid%sp32 ; pe(2) = grid%ep32 ; ps(3) = grid%sp33 ; pe(3) = grid%ep33 ;
3078	mxs(1) = grid%sm31x ; mxe(1) = grid%em31x
3079	mxs(2) = grid%sm32x ; mxe(2) = grid%em32x
3080	mxs(3) = grid%sm33x ; mxe(3) = grid%em33x
3081	pxs(1) = grid%sp31x ; pxe(1) = grid%ep31x
3082	pxs(2) = grid%sp32x ; pxe(2) = grid%ep32x
3083	pxs(3) = grid%sp33x ; pxe(3) = grid%ep33x
3084	mys(1) = grid%sm31y ; mye(1) = grid%em31y
3085	mys(2) = grid%sm32y ; mye(2) = grid%em32y
3086	mys(3) = grid%sm33y ; mye(3) = grid%em33y
3087	pys(1) = grid%sp31y ; pye(1) = grid%ep31y
3088	pys(2) = grid%sp32y ; pye(2) = grid%ep32y
3089	pys(3) = grid%sp33y ; pye(3) = grid%ep33y
3090	ELSE
3091	WRITE(mess,*)'internal error: get_ijk_from_grid_id: no such grid id:',id
3092	CALL wrf_error_fatal(TRIM(mess))
3093	ENDIF
3094
3095	END SUBROUTINE get_dims_from_grid_id
3096
3097	! find the grid based on the id reference and return that
3098	SUBROUTINE get_ijk_from_grid_id ( id , &
3099	ids, ide, jds, jde, kds, kde, &
3100	ims, ime, jms, jme, kms, kme, &
3101	ips, ipe, jps, jpe, kps, kpe, &
3102	imsx, imex, jmsx, jmex, kmsx, kmex, &
3103	ipsx, ipex, jpsx, jpex, kpsx, kpex, &
3104	imsy, imey, jmsy, jmey, kmsy, kmey, &
3105	ipsy, ipey, jpsy, jpey, kpsy, kpey )
3106	USE module_domain, ONLY : domain, head_grid, find_grid_by_id, get_ijk_from_grid
3107	IMPLICIT NONE
3108	TYPE( domain ), POINTER :: grid
3109	INTEGER, INTENT(IN ) :: id
3110	INTEGER, INTENT(OUT) :: &
3111	ids, ide, jds, jde, kds, kde, &
3112	ims, ime, jms, jme, kms, kme, &
3113	ips, ipe, jps, jpe, kps, kpe, &
3114	imsx, imex, jmsx, jmex, kmsx, kmex, &
3115	ipsx, ipex, jpsx, jpex, kpsx, kpex, &
3116	imsy, imey, jmsy, jmey, kmsy, kmey, &
3117	ipsy, ipey, jpsy, jpey, kpsy, kpey
3118	!local
3119	CHARACTER*256 mess
3120
3121	NULLIFY( grid )
3122	CALL find_grid_by_id ( id, head_grid, grid )
3123
3124	IF ( ASSOCIATED(grid) ) THEN
3125	CALL get_ijk_from_grid ( grid , &
3126	ids, ide, jds, jde, kds, kde, &
3127	ims, ime, jms, jme, kms, kme, &
3128	ips, ipe, jps, jpe, kps, kpe, &
3129	imsx, imex, jmsx, jmex, kmsx, kmex, &
3130	ipsx, ipex, jpsx, jpex, kpsx, kpex, &
3131	imsy, imey, jmsy, jmey, kmsy, kmey, &
3132	ipsy, ipey, jpsy, jpey, kpsy, kpey )
3133	ELSE
3134	WRITE(mess,*)'internal error: get_ijk_from_grid_id: no such grid id:',id
3135	CALL wrf_error_fatal(TRIM(mess))
3136	ENDIF
3137
3138	END SUBROUTINE get_ijk_from_grid_id
3139
3140	! version of this routine that can be called from set_scalar_indices_from_config in
3141	! module_configure, which can not USE module_domain without creating a circular use assocaition
3142	SUBROUTINE modify_io_masks ( id )
3143	USE module_domain, ONLY : domain, modify_io_masks1, head_grid, find_grid_by_id
3144	IMPLICIT NONE
3145	INTEGER, INTENT(IN) :: id
3146	TYPE(domain), POINTER :: grid
3147	CALL find_grid_by_id( id, head_grid, grid )
3148	IF ( ASSOCIATED( grid ) ) CALL modify_io_masks1( grid, id )
3149	RETURN
3150	END SUBROUTINE modify_io_masks
3151

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format