Context Navigation

module_domain.F

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

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

Download in other formats:

Original Format