source: lmdz_wrf/WRFV3/frame/module_domain.F @ 1

Last change on this file since 1 was 1, checked in by lfita, 10 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

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