Context Navigation

module_domain.F @ 3567

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

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

Download in other formats:

Original Format