Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

module_domain.F @ 3094

Last change on this file since 3094 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 93.6 KB

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

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

Download in other formats:

Original Format