1 | !WRF:DRIVER_LAYER:DOMAIN_OBJECT |
---|
2 | ! |
---|
3 | ! Following are the routines contained within this MODULE: |
---|
4 | |
---|
5 | ! alloc_and_configure_domain 1. Allocate the space for a single domain (constants |
---|
6 | ! and null terminate pointers). |
---|
7 | ! 2. Connect the domains as a linked list. |
---|
8 | ! 3. Store all of the domain constants. |
---|
9 | ! 4. CALL alloc_space_field. |
---|
10 | |
---|
11 | ! alloc_space_field 1. Allocate space for the gridded data required for |
---|
12 | ! each domain. |
---|
13 | |
---|
14 | ! dealloc_space_domain 1. Reconnect linked list nodes since the current |
---|
15 | ! node is removed. |
---|
16 | ! 2. CALL dealloc_space_field. |
---|
17 | ! 3. Deallocate single domain. |
---|
18 | |
---|
19 | ! dealloc_space_field 1. Deallocate each of the fields for a particular |
---|
20 | ! domain. |
---|
21 | |
---|
22 | ! first_loc_integer 1. Find the first incidence of a particular |
---|
23 | ! domain identifier from an array of domain |
---|
24 | ! identifiers. |
---|
25 | |
---|
26 | MODULE module_domain |
---|
27 | |
---|
28 | USE module_driver_constants |
---|
29 | USE module_machine |
---|
30 | USE module_configure |
---|
31 | USE module_wrf_error |
---|
32 | USE module_utility |
---|
33 | USE module_domain_type |
---|
34 | |
---|
35 | ! In WRFV3, the module_domain_type is defined |
---|
36 | ! in a separaate source file, frame/module_domain_type.F |
---|
37 | ! This enables splitting off the alloc_space_field routine |
---|
38 | ! into a separate file, reducing the size of module_domain |
---|
39 | |
---|
40 | ! Now that a "domain" TYPE exists, we can use it to store a few pointers |
---|
41 | ! to this type. These are primarily for use in traversing the linked list. |
---|
42 | ! The "head_grid" is always the pointer to the first domain that is |
---|
43 | ! allocated. This is available and is not to be changed. The others are |
---|
44 | ! just temporary pointers. |
---|
45 | |
---|
46 | TYPE(domain) , POINTER :: head_grid , new_grid , next_grid , old_grid |
---|
47 | |
---|
48 | ! To facilitate an easy integration of each of the domains that are on the |
---|
49 | ! same level, we have an array for the head pointer for each level. This |
---|
50 | ! removed the need to search through the linked list at each time step to |
---|
51 | ! find which domains are to be active. |
---|
52 | |
---|
53 | TYPE domain_levels |
---|
54 | TYPE(domain) , POINTER :: first_domain |
---|
55 | END TYPE domain_levels |
---|
56 | |
---|
57 | TYPE(domain_levels) , DIMENSION(max_levels) :: head_for_each_level |
---|
58 | |
---|
59 | ! Use this to support debugging features, giving easy access to clock, etc. |
---|
60 | TYPE(domain), POINTER :: current_grid |
---|
61 | LOGICAL, SAVE :: current_grid_set = .FALSE. |
---|
62 | |
---|
63 | ! internal routines |
---|
64 | PRIVATE domain_time_test_print |
---|
65 | PRIVATE test_adjust_io_timestr |
---|
66 | |
---|
67 | INTERFACE get_ijk_from_grid |
---|
68 | MODULE PROCEDURE get_ijk_from_grid1, get_ijk_from_grid2 |
---|
69 | END INTERFACE |
---|
70 | |
---|
71 | CONTAINS |
---|
72 | |
---|
73 | SUBROUTINE adjust_domain_dims_for_move( grid , dx, dy ) |
---|
74 | IMPLICIT NONE |
---|
75 | |
---|
76 | TYPE( domain ), POINTER :: grid |
---|
77 | INTEGER, INTENT(IN) :: dx, dy |
---|
78 | |
---|
79 | data_ordering : SELECT CASE ( model_data_order ) |
---|
80 | CASE ( DATA_ORDER_XYZ ) |
---|
81 | grid%sm31 = grid%sm31 + dx |
---|
82 | grid%em31 = grid%em31 + dx |
---|
83 | grid%sm32 = grid%sm32 + dy |
---|
84 | grid%em32 = grid%em32 + dy |
---|
85 | grid%sp31 = grid%sp31 + dx |
---|
86 | grid%ep31 = grid%ep31 + dx |
---|
87 | grid%sp32 = grid%sp32 + dy |
---|
88 | grid%ep32 = grid%ep32 + dy |
---|
89 | grid%sd31 = grid%sd31 + dx |
---|
90 | grid%ed31 = grid%ed31 + dx |
---|
91 | grid%sd32 = grid%sd32 + dy |
---|
92 | grid%ed32 = grid%ed32 + dy |
---|
93 | |
---|
94 | CASE ( DATA_ORDER_YXZ ) |
---|
95 | grid%sm31 = grid%sm31 + dy |
---|
96 | grid%em31 = grid%em31 + dy |
---|
97 | grid%sm32 = grid%sm32 + dx |
---|
98 | grid%em32 = grid%em32 + dx |
---|
99 | grid%sp31 = grid%sp31 + dy |
---|
100 | grid%ep31 = grid%ep31 + dy |
---|
101 | grid%sp32 = grid%sp32 + dx |
---|
102 | grid%ep32 = grid%ep32 + dx |
---|
103 | grid%sd31 = grid%sd31 + dy |
---|
104 | grid%ed31 = grid%ed31 + dy |
---|
105 | grid%sd32 = grid%sd32 + dx |
---|
106 | grid%ed32 = grid%ed32 + dx |
---|
107 | |
---|
108 | CASE ( DATA_ORDER_ZXY ) |
---|
109 | grid%sm32 = grid%sm32 + dx |
---|
110 | grid%em32 = grid%em32 + dx |
---|
111 | grid%sm33 = grid%sm33 + dy |
---|
112 | grid%em33 = grid%em33 + dy |
---|
113 | grid%sp32 = grid%sp32 + dx |
---|
114 | grid%ep32 = grid%ep32 + dx |
---|
115 | grid%sp33 = grid%sp33 + dy |
---|
116 | grid%ep33 = grid%ep33 + dy |
---|
117 | grid%sd32 = grid%sd32 + dx |
---|
118 | grid%ed32 = grid%ed32 + dx |
---|
119 | grid%sd33 = grid%sd33 + dy |
---|
120 | grid%ed33 = grid%ed33 + dy |
---|
121 | |
---|
122 | CASE ( DATA_ORDER_ZYX ) |
---|
123 | grid%sm32 = grid%sm32 + dy |
---|
124 | grid%em32 = grid%em32 + dy |
---|
125 | grid%sm33 = grid%sm33 + dx |
---|
126 | grid%em33 = grid%em33 + dx |
---|
127 | grid%sp32 = grid%sp32 + dy |
---|
128 | grid%ep32 = grid%ep32 + dy |
---|
129 | grid%sp33 = grid%sp33 + dx |
---|
130 | grid%ep33 = grid%ep33 + dx |
---|
131 | grid%sd32 = grid%sd32 + dy |
---|
132 | grid%ed32 = grid%ed32 + dy |
---|
133 | grid%sd33 = grid%sd33 + dx |
---|
134 | grid%ed33 = grid%ed33 + dx |
---|
135 | |
---|
136 | CASE ( DATA_ORDER_XZY ) |
---|
137 | grid%sm31 = grid%sm31 + dx |
---|
138 | grid%em31 = grid%em31 + dx |
---|
139 | grid%sm33 = grid%sm33 + dy |
---|
140 | grid%em33 = grid%em33 + dy |
---|
141 | grid%sp31 = grid%sp31 + dx |
---|
142 | grid%ep31 = grid%ep31 + dx |
---|
143 | grid%sp33 = grid%sp33 + dy |
---|
144 | grid%ep33 = grid%ep33 + dy |
---|
145 | grid%sd31 = grid%sd31 + dx |
---|
146 | grid%ed31 = grid%ed31 + dx |
---|
147 | grid%sd33 = grid%sd33 + dy |
---|
148 | grid%ed33 = grid%ed33 + dy |
---|
149 | |
---|
150 | CASE ( DATA_ORDER_YZX ) |
---|
151 | grid%sm31 = grid%sm31 + dy |
---|
152 | grid%em31 = grid%em31 + dy |
---|
153 | grid%sm33 = grid%sm33 + dx |
---|
154 | grid%em33 = grid%em33 + dx |
---|
155 | grid%sp31 = grid%sp31 + dy |
---|
156 | grid%ep31 = grid%ep31 + dy |
---|
157 | grid%sp33 = grid%sp33 + dx |
---|
158 | grid%ep33 = grid%ep33 + dx |
---|
159 | grid%sd31 = grid%sd31 + dy |
---|
160 | grid%ed31 = grid%ed31 + dy |
---|
161 | grid%sd33 = grid%sd33 + dx |
---|
162 | grid%ed33 = grid%ed33 + dx |
---|
163 | |
---|
164 | END SELECT data_ordering |
---|
165 | |
---|
166 | #if 0 |
---|
167 | CALL dealloc_space_field ( grid ) |
---|
168 | |
---|
169 | CALL alloc_space_field ( grid, grid%id , 1 , 2 , .FALSE. , & |
---|
170 | grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & |
---|
171 | grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & |
---|
172 | grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & |
---|
173 | grid%sp31x, grid%ep31x, grid%sp32x, grid%ep32x, grid%sp33x, grid%ep33x, & |
---|
174 | grid%sp31y, grid%ep31y, grid%sp32y, grid%ep32y, grid%sp33y, grid%ep33y, & |
---|
175 | grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose |
---|
176 | grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose |
---|
177 | ) |
---|
178 | #endif |
---|
179 | |
---|
180 | RETURN |
---|
181 | END SUBROUTINE adjust_domain_dims_for_move |
---|
182 | |
---|
183 | #if 1 |
---|
184 | SUBROUTINE get_ijk_from_grid1 ( grid , & |
---|
185 | ids, ide, jds, jde, kds, kde, & |
---|
186 | ims, ime, jms, jme, kms, kme, & |
---|
187 | ips, ipe, jps, jpe, kps, kpe, & |
---|
188 | imsx, imex, jmsx, jmex, kmsx, kmex, & |
---|
189 | ipsx, ipex, jpsx, jpex, kpsx, kpex, & |
---|
190 | imsy, imey, jmsy, jmey, kmsy, kmey, & |
---|
191 | ipsy, ipey, jpsy, jpey, kpsy, kpey ) |
---|
192 | IMPLICIT NONE |
---|
193 | TYPE( domain ), INTENT (IN) :: grid |
---|
194 | INTEGER, INTENT(OUT) :: & |
---|
195 | ids, ide, jds, jde, kds, kde, & |
---|
196 | ims, ime, jms, jme, kms, kme, & |
---|
197 | ips, ipe, jps, jpe, kps, kpe, & |
---|
198 | imsx, imex, jmsx, jmex, kmsx, kmex, & |
---|
199 | ipsx, ipex, jpsx, jpex, kpsx, kpex, & |
---|
200 | imsy, imey, jmsy, jmey, kmsy, kmey, & |
---|
201 | ipsy, ipey, jpsy, jpey, kpsy, kpey |
---|
202 | |
---|
203 | CALL get_ijk_from_grid2 ( grid , & |
---|
204 | ids, ide, jds, jde, kds, kde, & |
---|
205 | ims, ime, jms, jme, kms, kme, & |
---|
206 | ips, ipe, jps, jpe, kps, kpe ) |
---|
207 | data_ordering : SELECT CASE ( model_data_order ) |
---|
208 | CASE ( DATA_ORDER_XYZ ) |
---|
209 | imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm33x ; kmex = grid%em33x ; |
---|
210 | ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp33x ; kpex = grid%ep33x ; |
---|
211 | imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm33y ; kmey = grid%em33y ; |
---|
212 | ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp33y ; kpey = grid%ep33y ; |
---|
213 | CASE ( DATA_ORDER_YXZ ) |
---|
214 | imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm33x ; kmex = grid%em33x ; |
---|
215 | ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp33x ; kpex = grid%ep33x ; |
---|
216 | imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm33y ; kmey = grid%em33y ; |
---|
217 | ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp33y ; kpey = grid%ep33y ; |
---|
218 | CASE ( DATA_ORDER_ZXY ) |
---|
219 | imsx = grid%sm32x ; imex = grid%em32x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm31x ; kmex = grid%em31x ; |
---|
220 | ipsx = grid%sp32x ; ipex = grid%ep32x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp31x ; kpex = grid%ep31x ; |
---|
221 | imsy = grid%sm32y ; imey = grid%em32y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm31y ; kmey = grid%em31y ; |
---|
222 | ipsy = grid%sp32y ; ipey = grid%ep32y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp31y ; kpey = grid%ep31y ; |
---|
223 | CASE ( DATA_ORDER_ZYX ) |
---|
224 | imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm32x ; jmex = grid%em32x ; kmsx = grid%sm31x ; kmex = grid%em31x ; |
---|
225 | ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp32x ; jpex = grid%ep32x ; kpsx = grid%sp31x ; kpex = grid%ep31x ; |
---|
226 | imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm32y ; jmey = grid%em32y ; kmsy = grid%sm31y ; kmey = grid%em31y ; |
---|
227 | ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp32y ; jpey = grid%ep32y ; kpsy = grid%sp31y ; kpey = grid%ep31y ; |
---|
228 | CASE ( DATA_ORDER_XZY ) |
---|
229 | imsx = grid%sm31x ; imex = grid%em31x ; jmsx = grid%sm33x ; jmex = grid%em33x ; kmsx = grid%sm32x ; kmex = grid%em32x ; |
---|
230 | ipsx = grid%sp31x ; ipex = grid%ep31x ; jpsx = grid%sp33x ; jpex = grid%ep33x ; kpsx = grid%sp32x ; kpex = grid%ep32x ; |
---|
231 | imsy = grid%sm31y ; imey = grid%em31y ; jmsy = grid%sm33y ; jmey = grid%em33y ; kmsy = grid%sm32y ; kmey = grid%em32y ; |
---|
232 | ipsy = grid%sp31y ; ipey = grid%ep31y ; jpsy = grid%sp33y ; jpey = grid%ep33y ; kpsy = grid%sp32y ; kpey = grid%ep32y ; |
---|
233 | CASE ( DATA_ORDER_YZX ) |
---|
234 | imsx = grid%sm33x ; imex = grid%em33x ; jmsx = grid%sm31x ; jmex = grid%em31x ; kmsx = grid%sm32x ; kmex = grid%em32x ; |
---|
235 | ipsx = grid%sp33x ; ipex = grid%ep33x ; jpsx = grid%sp31x ; jpex = grid%ep31x ; kpsx = grid%sp32x ; kpex = grid%ep32x ; |
---|
236 | imsy = grid%sm33y ; imey = grid%em33y ; jmsy = grid%sm31y ; jmey = grid%em31y ; kmsy = grid%sm32y ; kmey = grid%em32y ; |
---|
237 | ipsy = grid%sp33y ; ipey = grid%ep33y ; jpsy = grid%sp31y ; jpey = grid%ep31y ; kpsy = grid%sp32y ; kpey = grid%ep32y ; |
---|
238 | END SELECT data_ordering |
---|
239 | END SUBROUTINE get_ijk_from_grid1 |
---|
240 | |
---|
241 | SUBROUTINE get_ijk_from_grid2 ( grid , & |
---|
242 | ids, ide, jds, jde, kds, kde, & |
---|
243 | ims, ime, jms, jme, kms, kme, & |
---|
244 | ips, ipe, jps, jpe, kps, kpe ) |
---|
245 | |
---|
246 | IMPLICIT NONE |
---|
247 | |
---|
248 | TYPE( domain ), INTENT (IN) :: grid |
---|
249 | INTEGER, INTENT(OUT) :: & |
---|
250 | ids, ide, jds, jde, kds, kde, & |
---|
251 | ims, ime, jms, jme, kms, kme, & |
---|
252 | ips, ipe, jps, jpe, kps, kpe |
---|
253 | |
---|
254 | data_ordering : SELECT CASE ( model_data_order ) |
---|
255 | CASE ( DATA_ORDER_XYZ ) |
---|
256 | ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd33 ; kde = grid%ed33 ; |
---|
257 | ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm33 ; kme = grid%em33 ; |
---|
258 | ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp33 ; kpe = grid%ep33 ; |
---|
259 | CASE ( DATA_ORDER_YXZ ) |
---|
260 | ids = grid%sd32 ; ide = grid%ed32 ; jds = grid%sd31 ; jde = grid%ed31 ; kds = grid%sd33 ; kde = grid%ed33 ; |
---|
261 | ims = grid%sm32 ; ime = grid%em32 ; jms = grid%sm31 ; jme = grid%em31 ; kms = grid%sm33 ; kme = grid%em33 ; |
---|
262 | ips = grid%sp32 ; ipe = grid%ep32 ; jps = grid%sp31 ; jpe = grid%ep31 ; kps = grid%sp33 ; kpe = grid%ep33 ; |
---|
263 | CASE ( DATA_ORDER_ZXY ) |
---|
264 | ids = grid%sd32 ; ide = grid%ed32 ; jds = grid%sd33 ; jde = grid%ed33 ; kds = grid%sd31 ; kde = grid%ed31 ; |
---|
265 | ims = grid%sm32 ; ime = grid%em32 ; jms = grid%sm33 ; jme = grid%em33 ; kms = grid%sm31 ; kme = grid%em31 ; |
---|
266 | ips = grid%sp32 ; ipe = grid%ep32 ; jps = grid%sp33 ; jpe = grid%ep33 ; kps = grid%sp31 ; kpe = grid%ep31 ; |
---|
267 | CASE ( DATA_ORDER_ZYX ) |
---|
268 | ids = grid%sd33 ; ide = grid%ed33 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd31 ; kde = grid%ed31 ; |
---|
269 | ims = grid%sm33 ; ime = grid%em33 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm31 ; kme = grid%em31 ; |
---|
270 | ips = grid%sp33 ; ipe = grid%ep33 ; jps = grid%sp32 ; jpe = grid%ep32 ; kps = grid%sp31 ; kpe = grid%ep31 ; |
---|
271 | CASE ( DATA_ORDER_XZY ) |
---|
272 | ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd33 ; jde = grid%ed33 ; kds = grid%sd32 ; kde = grid%ed32 ; |
---|
273 | ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm33 ; jme = grid%em33 ; kms = grid%sm32 ; kme = grid%em32 ; |
---|
274 | ips = grid%sp31 ; ipe = grid%ep31 ; jps = grid%sp33 ; jpe = grid%ep33 ; kps = grid%sp32 ; kpe = grid%ep32 ; |
---|
275 | CASE ( DATA_ORDER_YZX ) |
---|
276 | ids = grid%sd33 ; ide = grid%ed33 ; jds = grid%sd31 ; jde = grid%ed31 ; kds = grid%sd32 ; kde = grid%ed32 ; |
---|
277 | ims = grid%sm33 ; ime = grid%em33 ; jms = grid%sm31 ; jme = grid%em31 ; kms = grid%sm32 ; kme = grid%em32 ; |
---|
278 | ips = grid%sp33 ; ipe = grid%ep33 ; jps = grid%sp31 ; jpe = grid%ep31 ; kps = grid%sp32 ; kpe = grid%ep32 ; |
---|
279 | END SELECT data_ordering |
---|
280 | END SUBROUTINE get_ijk_from_grid2 |
---|
281 | |
---|
282 | ! return the values for subgrid whose refinement is in grid%sr |
---|
283 | ! note when using this routine, it does not affect K. For K |
---|
284 | ! (vertical), it just returns what get_ijk_from_grid does |
---|
285 | SUBROUTINE get_ijk_from_subgrid ( grid , & |
---|
286 | ids0, ide0, jds0, jde0, kds0, kde0, & |
---|
287 | ims0, ime0, jms0, jme0, kms0, kme0, & |
---|
288 | ips0, ipe0, jps0, jpe0, kps0, kpe0 ) |
---|
289 | TYPE( domain ), INTENT (IN) :: grid |
---|
290 | INTEGER, INTENT(OUT) :: & |
---|
291 | ids0, ide0, jds0, jde0, kds0, kde0, & |
---|
292 | ims0, ime0, jms0, jme0, kms0, kme0, & |
---|
293 | ips0, ipe0, jps0, jpe0, kps0, kpe0 |
---|
294 | ! Local |
---|
295 | INTEGER :: & |
---|
296 | ids, ide, jds, jde, kds, kde, & |
---|
297 | ims, ime, jms, jme, kms, kme, & |
---|
298 | ips, ipe, jps, jpe, kps, kpe |
---|
299 | CALL get_ijk_from_grid ( grid , & |
---|
300 | ids, ide, jds, jde, kds, kde, & |
---|
301 | ims, ime, jms, jme, kms, kme, & |
---|
302 | ips, ipe, jps, jpe, kps, kpe ) |
---|
303 | ids0 = ids |
---|
304 | ide0 = ide * grid%sr_x |
---|
305 | ims0 = (ims-1)*grid%sr_x+1 |
---|
306 | ime0 = ime * grid%sr_x |
---|
307 | ips0 = (ips-1)*grid%sr_x+1 |
---|
308 | ipe0 = ipe * grid%sr_x |
---|
309 | |
---|
310 | jds0 = jds |
---|
311 | jde0 = jde * grid%sr_y |
---|
312 | jms0 = (jms-1)*grid%sr_y+1 |
---|
313 | jme0 = jme * grid%sr_y |
---|
314 | jps0 = (jps-1)*grid%sr_y+1 |
---|
315 | jpe0 = jpe * grid%sr_y |
---|
316 | |
---|
317 | kds0 = kds |
---|
318 | kde0 = kde |
---|
319 | kms0 = kms |
---|
320 | kme0 = kme |
---|
321 | kps0 = kps |
---|
322 | kpe0 = kpe |
---|
323 | RETURN |
---|
324 | END SUBROUTINE get_ijk_from_subgrid |
---|
325 | #endif |
---|
326 | |
---|
327 | |
---|
328 | ! Default version ; Otherwise module containing interface to DM library will provide |
---|
329 | |
---|
330 | SUBROUTINE wrf_patch_domain( id , domdesc , parent, parent_id , parent_domdesc , & |
---|
331 | sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & |
---|
332 | sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & |
---|
333 | sd3 , ed3 , sp3 , ep3 , sm3 , em3 , & |
---|
334 | sp1x , ep1x , sm1x , em1x , & |
---|
335 | sp2x , ep2x , sm2x , em2x , & |
---|
336 | sp3x , ep3x , sm3x , em3x , & |
---|
337 | sp1y , ep1y , sm1y , em1y , & |
---|
338 | sp2y , ep2y , sm2y , em2y , & |
---|
339 | sp3y , ep3y , sm3y , em3y , & |
---|
340 | bdx , bdy , bdy_mask ) |
---|
341 | !<DESCRIPTION> |
---|
342 | ! Wrf_patch_domain is called as part of the process of initiating a new |
---|
343 | ! domain. Based on the global domain dimension information that is |
---|
344 | ! passed in it computes the patch and memory dimensions on this |
---|
345 | ! distributed-memory process for parallel compilation when DM_PARALLEL is |
---|
346 | ! defined in configure.wrf. In this case, it relies on an external |
---|
347 | ! communications package-contributed routine, wrf_dm_patch_domain. For |
---|
348 | ! non-parallel compiles, it returns the patch and memory dimensions based |
---|
349 | ! on the entire domain. In either case, the memory dimensions will be |
---|
350 | ! larger than the patch dimensions, since they allow for distributed |
---|
351 | ! memory halo regions (DM_PARALLEL only) and for boundary regions around |
---|
352 | ! the domain (used for idealized cases only). The width of the boundary |
---|
353 | ! regions to be accommodated is passed in as bdx and bdy. |
---|
354 | ! |
---|
355 | ! The bdy_mask argument is a four-dimensional logical array, each element |
---|
356 | ! of which is set to true for any boundaries that this process's patch |
---|
357 | ! contains (all four are true in the non-DM_PARALLEL case) and false |
---|
358 | ! otherwise. The indices into the bdy_mask are defined in |
---|
359 | ! frame/module_state_description.F. P_XSB corresponds boundary that |
---|
360 | ! exists at the beginning of the X-dimension; ie. the western boundary; |
---|
361 | ! P_XEB to the boundary that corresponds to the end of the X-dimension |
---|
362 | ! (east). Likewise for Y (south and north respectively). |
---|
363 | ! |
---|
364 | ! The correspondence of the first, second, and third dimension of each |
---|
365 | ! set (domain, memory, and patch) with the coordinate axes of the model |
---|
366 | ! domain is based on the setting of the variable model_data_order, which |
---|
367 | ! comes into this routine through USE association of |
---|
368 | ! module_driver_constants in the enclosing module of this routine, |
---|
369 | ! module_domain. Model_data_order is defined by the Registry, based on |
---|
370 | ! the dimspec entries which associate dimension specifiers (e.g. 'k') in |
---|
371 | ! the Registry with a coordinate axis and specify which dimension of the |
---|
372 | ! arrays they represent. For WRF, the sd1 , ed1 , sp1 , ep1 , sm1 , and |
---|
373 | ! em1 correspond to the starts and ends of the global, patch, and memory |
---|
374 | ! dimensions in X; those with 2 specify Z (vertical); and those with 3 |
---|
375 | ! specify Y. Note that the WRF convention is to overdimension to allow |
---|
376 | ! for staggered fields so that sd<em>n</em>:ed<em>n</em> are the starts |
---|
377 | ! and ends of the staggered domains in X. The non-staggered grid runs |
---|
378 | ! sd<em>n</em>:ed<em>n</em>-1. The extra row or column on the north or |
---|
379 | ! east boundaries is not used for non-staggered fields. |
---|
380 | ! |
---|
381 | ! The domdesc and parent_domdesc arguments are for external communication |
---|
382 | ! packages (e.g. RSL) that establish and return to WRF integer handles |
---|
383 | ! for referring to operations on domains. These descriptors are not set |
---|
384 | ! or used otherwise and they are opaque, which means they are never |
---|
385 | ! accessed or modified in WRF; they are only only passed between calls to |
---|
386 | ! the external package. |
---|
387 | !</DESCRIPTION> |
---|
388 | |
---|
389 | USE module_machine |
---|
390 | IMPLICIT NONE |
---|
391 | LOGICAL, DIMENSION(4), INTENT(OUT) :: bdy_mask |
---|
392 | INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy |
---|
393 | INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , & ! z-xpose (std) |
---|
394 | sm1 , em1 , sm2 , em2 , sm3 , em3 |
---|
395 | INTEGER, INTENT(OUT) :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , & ! x-xpose |
---|
396 | sm1x , em1x , sm2x , em2x , sm3x , em3x |
---|
397 | INTEGER, INTENT(OUT) :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , & ! y-xpose |
---|
398 | sm1y , em1y , sm2y , em2y , sm3y , em3y |
---|
399 | INTEGER, INTENT(IN) :: id , parent_id , parent_domdesc |
---|
400 | INTEGER, INTENT(INOUT) :: domdesc |
---|
401 | TYPE(domain), POINTER :: parent |
---|
402 | |
---|
403 | !local data |
---|
404 | |
---|
405 | INTEGER spec_bdy_width |
---|
406 | |
---|
407 | CALL nl_get_spec_bdy_width( 1, spec_bdy_width ) |
---|
408 | |
---|
409 | #ifndef DM_PARALLEL |
---|
410 | |
---|
411 | bdy_mask = .true. ! only one processor so all 4 boundaries are there |
---|
412 | |
---|
413 | ! this is a trivial version -- 1 patch per processor; |
---|
414 | ! use version in module_dm to compute for DM |
---|
415 | sp1 = sd1 ; sp2 = sd2 ; sp3 = sd3 |
---|
416 | ep1 = ed1 ; ep2 = ed2 ; ep3 = ed3 |
---|
417 | SELECT CASE ( model_data_order ) |
---|
418 | CASE ( DATA_ORDER_XYZ ) |
---|
419 | sm1 = sp1 - bdx ; em1 = ep1 + bdx |
---|
420 | sm2 = sp2 - bdy ; em2 = ep2 + bdy |
---|
421 | sm3 = sp3 ; em3 = ep3 |
---|
422 | CASE ( DATA_ORDER_YXZ ) |
---|
423 | sm1 = sp1 - bdy ; em1 = ep1 + bdy |
---|
424 | sm2 = sp2 - bdx ; em2 = ep2 + bdx |
---|
425 | sm3 = sp3 ; em3 = ep3 |
---|
426 | CASE ( DATA_ORDER_ZXY ) |
---|
427 | sm1 = sp1 ; em1 = ep1 |
---|
428 | sm2 = sp2 - bdx ; em2 = ep2 + bdx |
---|
429 | sm3 = sp3 - bdy ; em3 = ep3 + bdy |
---|
430 | CASE ( DATA_ORDER_ZYX ) |
---|
431 | sm1 = sp1 ; em1 = ep1 |
---|
432 | sm2 = sp2 - bdy ; em2 = ep2 + bdy |
---|
433 | sm3 = sp3 - bdx ; em3 = ep3 + bdx |
---|
434 | CASE ( DATA_ORDER_XZY ) |
---|
435 | sm1 = sp1 - bdx ; em1 = ep1 + bdx |
---|
436 | sm2 = sp2 ; em2 = ep2 |
---|
437 | sm3 = sp3 - bdy ; em3 = ep3 + bdy |
---|
438 | CASE ( DATA_ORDER_YZX ) |
---|
439 | sm1 = sp1 - bdy ; em1 = ep1 + bdy |
---|
440 | sm2 = sp2 ; em2 = ep2 |
---|
441 | sm3 = sp3 - bdx ; em3 = ep3 + bdx |
---|
442 | END SELECT |
---|
443 | sm1x = sm1 ; em1x = em1 ! just copy |
---|
444 | sm2x = sm2 ; em2x = em2 |
---|
445 | sm3x = sm3 ; em3x = em3 |
---|
446 | sm1y = sm1 ; em1y = em1 ! just copy |
---|
447 | sm2y = sm2 ; em2y = em2 |
---|
448 | sm3y = sm3 ; em3y = em3 |
---|
449 | ! assigns mostly just to suppress warning messages that INTENT OUT vars not assigned |
---|
450 | sp1x = sp1 ; ep1x = ep1 ; sp2x = sp2 ; ep2x = ep2 ; sp3x = sp3 ; ep3x = ep3 |
---|
451 | sp1y = sp1 ; ep1y = ep1 ; sp2y = sp2 ; ep2y = ep2 ; sp3y = sp3 ; ep3y = ep3 |
---|
452 | |
---|
453 | #else |
---|
454 | ! This is supplied by the package specific version of module_dm, which |
---|
455 | ! is supplied by the external package and copied into the src directory |
---|
456 | ! when the code is compiled. The cp command will be found in the externals |
---|
457 | ! target of the configure.wrf file for this architecture. Eg: for RSL |
---|
458 | ! routine is defined in external/RSL/module_dm.F . |
---|
459 | ! Note, it would be very nice to be able to pass parent to this routine; |
---|
460 | ! however, there doesn't seem to be a way to do that in F90. That is because |
---|
461 | ! to pass a pointer to a domain structure, this call requires an interface |
---|
462 | ! definition for wrf_dm_patch_domain (otherwise it will try to convert the |
---|
463 | ! pointer to something). In order to provide an interface definition, we |
---|
464 | ! would need to either USE module_dm or use an interface block. In either |
---|
465 | ! case it generates a circular USE reference, since module_dm uses |
---|
466 | ! module_domain. JM 20020416 |
---|
467 | |
---|
468 | CALL wrf_dm_patch_domain( id , domdesc , parent_id , parent_domdesc , & |
---|
469 | sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & |
---|
470 | sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & |
---|
471 | sd3 , ed3 , sp3 , ep3 , sm3 , em3 , & |
---|
472 | sp1x , ep1x , sm1x , em1x , & |
---|
473 | sp2x , ep2x , sm2x , em2x , & |
---|
474 | sp3x , ep3x , sm3x , em3x , & |
---|
475 | sp1y , ep1y , sm1y , em1y , & |
---|
476 | sp2y , ep2y , sm2y , em2y , & |
---|
477 | sp3y , ep3y , sm3y , em3y , & |
---|
478 | bdx , bdy ) |
---|
479 | |
---|
480 | SELECT CASE ( model_data_order ) |
---|
481 | CASE ( DATA_ORDER_XYZ ) |
---|
482 | bdy_mask( P_XSB ) = ( sd1 <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 ) |
---|
483 | bdy_mask( P_YSB ) = ( sd2 <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 ) |
---|
484 | bdy_mask( P_XEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1 ) |
---|
485 | bdy_mask( P_YEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2 ) |
---|
486 | CASE ( DATA_ORDER_YXZ ) |
---|
487 | bdy_mask( P_XSB ) = ( sd2 <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 ) |
---|
488 | bdy_mask( P_YSB ) = ( sd1 <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 ) |
---|
489 | bdy_mask( P_XEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2 ) |
---|
490 | bdy_mask( P_YEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1 ) |
---|
491 | CASE ( DATA_ORDER_ZXY ) |
---|
492 | bdy_mask( P_XSB ) = ( sd2 <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 ) |
---|
493 | bdy_mask( P_YSB ) = ( sd3 <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 ) |
---|
494 | bdy_mask( P_XEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2 ) |
---|
495 | bdy_mask( P_YEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3 ) |
---|
496 | CASE ( DATA_ORDER_ZYX ) |
---|
497 | bdy_mask( P_XSB ) = ( sd3 <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 ) |
---|
498 | bdy_mask( P_YSB ) = ( sd2 <= sp2 .AND. sp2 <= sd2+spec_bdy_width-1 ) |
---|
499 | bdy_mask( P_XEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3 ) |
---|
500 | bdy_mask( P_YEB ) = ( ed2-spec_bdy_width-1 <= ep2 .AND. ep2 <= ed2 ) |
---|
501 | CASE ( DATA_ORDER_XZY ) |
---|
502 | bdy_mask( P_XSB ) = ( sd1 <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 ) |
---|
503 | bdy_mask( P_YSB ) = ( sd3 <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 ) |
---|
504 | bdy_mask( P_XEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1 ) |
---|
505 | bdy_mask( P_YEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3 ) |
---|
506 | CASE ( DATA_ORDER_YZX ) |
---|
507 | bdy_mask( P_XSB ) = ( sd3 <= sp3 .AND. sp3 <= sd3+spec_bdy_width-1 ) |
---|
508 | bdy_mask( P_YSB ) = ( sd1 <= sp1 .AND. sp1 <= sd1+spec_bdy_width-1 ) |
---|
509 | bdy_mask( P_XEB ) = ( ed3-spec_bdy_width-1 <= ep3 .AND. ep3 <= ed3 ) |
---|
510 | bdy_mask( P_YEB ) = ( ed1-spec_bdy_width-1 <= ep1 .AND. ep1 <= ed1 ) |
---|
511 | END SELECT |
---|
512 | |
---|
513 | #endif |
---|
514 | |
---|
515 | RETURN |
---|
516 | END SUBROUTINE wrf_patch_domain |
---|
517 | ! |
---|
518 | SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid ) |
---|
519 | |
---|
520 | !<DESCRIPTION> |
---|
521 | ! This subroutine is used to allocate a domain data structure of |
---|
522 | ! TYPE(DOMAIN) pointed to by the argument <em>grid</em>, link it into the |
---|
523 | ! nested domain hierarchy, and set it's configuration information from |
---|
524 | ! the appropriate settings in the WRF namelist file. Specifically, if the |
---|
525 | ! domain being allocated and configured is nest, the <em>parent</em> |
---|
526 | ! argument will point to the already existing domain data structure for |
---|
527 | ! the parent domain and the <em>kid</em> argument will be set to an |
---|
528 | ! integer indicating which child of the parent this grid will be (child |
---|
529 | ! indices start at 1). If this is the top-level domain, the parent and |
---|
530 | ! kid arguments are ignored. <b>WRF domains may have multiple children |
---|
531 | ! but only ever have one parent.</b> |
---|
532 | ! |
---|
533 | ! The <em>domain_id</em> argument is the |
---|
534 | ! integer handle by which this new domain will be referred; it comes from |
---|
535 | ! the grid_id setting in the namelist, and these grid ids correspond to |
---|
536 | ! the ordering of settings in the namelist, starting with 1 for the |
---|
537 | ! top-level domain. The id of 1 always corresponds to the top-level |
---|
538 | ! domain. and these grid ids correspond to the ordering of settings in |
---|
539 | ! the namelist, starting with 1 for the top-level domain. |
---|
540 | ! |
---|
541 | ! Model_data_order is provide by USE association of |
---|
542 | ! module_driver_constants and is set from dimspec entries in the |
---|
543 | ! Registry. |
---|
544 | ! |
---|
545 | ! The allocation of the TYPE(DOMAIN) itself occurs in this routine. |
---|
546 | ! However, the numerous multi-dimensional arrays that make up the members |
---|
547 | ! of the domain are allocated in the call to alloc_space_field, after |
---|
548 | ! wrf_patch_domain has been called to determine the dimensions in memory |
---|
549 | ! that should be allocated. It bears noting here that arrays and code |
---|
550 | ! that indexes these arrays are always global, regardless of how the |
---|
551 | ! model is decomposed over patches. Thus, when arrays are allocated on a |
---|
552 | ! given process, the start and end of an array dimension are the global |
---|
553 | ! indices of the start and end of that process's subdomain. |
---|
554 | ! |
---|
555 | ! Configuration information for the domain (that is, information from the |
---|
556 | ! namelist) is added by the call to <a href=med_add_config_info_to_grid.html>med_add_config_info_to_grid</a>, defined |
---|
557 | ! in share/mediation_wrfmain.F. |
---|
558 | !</DESCRIPTION> |
---|
559 | |
---|
560 | IMPLICIT NONE |
---|
561 | |
---|
562 | ! Input data. |
---|
563 | |
---|
564 | INTEGER , INTENT(IN) :: domain_id |
---|
565 | TYPE( domain ) , POINTER :: grid |
---|
566 | TYPE( domain ) , POINTER :: parent |
---|
567 | INTEGER , INTENT(IN) :: kid ! which kid of parent am I? |
---|
568 | |
---|
569 | ! Local data. |
---|
570 | INTEGER :: sd1 , ed1 , sp1 , ep1 , sm1 , em1 |
---|
571 | INTEGER :: sd2 , ed2 , sp2 , ep2 , sm2 , em2 |
---|
572 | INTEGER :: sd3 , ed3 , sp3 , ep3 , sm3 , em3 |
---|
573 | |
---|
574 | INTEGER :: sd1x , ed1x , sp1x , ep1x , sm1x , em1x |
---|
575 | INTEGER :: sd2x , ed2x , sp2x , ep2x , sm2x , em2x |
---|
576 | INTEGER :: sd3x , ed3x , sp3x , ep3x , sm3x , em3x |
---|
577 | |
---|
578 | INTEGER :: sd1y , ed1y , sp1y , ep1y , sm1y , em1y |
---|
579 | INTEGER :: sd2y , ed2y , sp2y , ep2y , sm2y , em2y |
---|
580 | INTEGER :: sd3y , ed3y , sp3y , ep3y , sm3y , em3y |
---|
581 | |
---|
582 | TYPE(domain) , POINTER :: new_grid |
---|
583 | INTEGER :: i |
---|
584 | INTEGER :: parent_id , parent_domdesc , new_domdesc |
---|
585 | INTEGER :: bdyzone_x , bdyzone_y |
---|
586 | INTEGER :: nx, ny |
---|
587 | |
---|
588 | |
---|
589 | ! This next step uses information that is listed in the registry as namelist_derived |
---|
590 | ! to properly size the domain and the patches; this in turn is stored in the new_grid |
---|
591 | ! data structure |
---|
592 | |
---|
593 | |
---|
594 | data_ordering : SELECT CASE ( model_data_order ) |
---|
595 | CASE ( DATA_ORDER_XYZ ) |
---|
596 | |
---|
597 | CALL nl_get_s_we( domain_id , sd1 ) |
---|
598 | CALL nl_get_e_we( domain_id , ed1 ) |
---|
599 | CALL nl_get_s_sn( domain_id , sd2 ) |
---|
600 | CALL nl_get_e_sn( domain_id , ed2 ) |
---|
601 | CALL nl_get_s_vert( domain_id , sd3 ) |
---|
602 | CALL nl_get_e_vert( domain_id , ed3 ) |
---|
603 | nx = ed1-sd1+1 |
---|
604 | ny = ed2-sd2+1 |
---|
605 | |
---|
606 | CASE ( DATA_ORDER_YXZ ) |
---|
607 | |
---|
608 | CALL nl_get_s_sn( domain_id , sd1 ) |
---|
609 | CALL nl_get_e_sn( domain_id , ed1 ) |
---|
610 | CALL nl_get_s_we( domain_id , sd2 ) |
---|
611 | CALL nl_get_e_we( domain_id , ed2 ) |
---|
612 | CALL nl_get_s_vert( domain_id , sd3 ) |
---|
613 | CALL nl_get_e_vert( domain_id , ed3 ) |
---|
614 | nx = ed2-sd2+1 |
---|
615 | ny = ed1-sd1+1 |
---|
616 | |
---|
617 | CASE ( DATA_ORDER_ZXY ) |
---|
618 | |
---|
619 | CALL nl_get_s_vert( domain_id , sd1 ) |
---|
620 | CALL nl_get_e_vert( domain_id , ed1 ) |
---|
621 | CALL nl_get_s_we( domain_id , sd2 ) |
---|
622 | CALL nl_get_e_we( domain_id , ed2 ) |
---|
623 | CALL nl_get_s_sn( domain_id , sd3 ) |
---|
624 | CALL nl_get_e_sn( domain_id , ed3 ) |
---|
625 | nx = ed2-sd2+1 |
---|
626 | ny = ed3-sd3+1 |
---|
627 | |
---|
628 | CASE ( DATA_ORDER_ZYX ) |
---|
629 | |
---|
630 | CALL nl_get_s_vert( domain_id , sd1 ) |
---|
631 | CALL nl_get_e_vert( domain_id , ed1 ) |
---|
632 | CALL nl_get_s_sn( domain_id , sd2 ) |
---|
633 | CALL nl_get_e_sn( domain_id , ed2 ) |
---|
634 | CALL nl_get_s_we( domain_id , sd3 ) |
---|
635 | CALL nl_get_e_we( domain_id , ed3 ) |
---|
636 | nx = ed3-sd3+1 |
---|
637 | ny = ed2-sd2+1 |
---|
638 | |
---|
639 | CASE ( DATA_ORDER_XZY ) |
---|
640 | |
---|
641 | CALL nl_get_s_we( domain_id , sd1 ) |
---|
642 | CALL nl_get_e_we( domain_id , ed1 ) |
---|
643 | CALL nl_get_s_vert( domain_id , sd2 ) |
---|
644 | CALL nl_get_e_vert( domain_id , ed2 ) |
---|
645 | CALL nl_get_s_sn( domain_id , sd3 ) |
---|
646 | CALL nl_get_e_sn( domain_id , ed3 ) |
---|
647 | nx = ed1-sd1+1 |
---|
648 | ny = ed3-sd3+1 |
---|
649 | |
---|
650 | CASE ( DATA_ORDER_YZX ) |
---|
651 | |
---|
652 | CALL nl_get_s_sn( domain_id , sd1 ) |
---|
653 | CALL nl_get_e_sn( domain_id , ed1 ) |
---|
654 | CALL nl_get_s_vert( domain_id , sd2 ) |
---|
655 | CALL nl_get_e_vert( domain_id , ed2 ) |
---|
656 | CALL nl_get_s_we( domain_id , sd3 ) |
---|
657 | CALL nl_get_e_we( domain_id , ed3 ) |
---|
658 | nx = ed3-sd3+1 |
---|
659 | ny = ed1-sd1+1 |
---|
660 | |
---|
661 | END SELECT data_ordering |
---|
662 | |
---|
663 | IF ( num_time_levels > 3 ) THEN |
---|
664 | WRITE ( wrf_err_message , * ) 'alloc_and_configure_domain: ', & |
---|
665 | 'Incorrect value for num_time_levels ', num_time_levels |
---|
666 | CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) |
---|
667 | ENDIF |
---|
668 | |
---|
669 | IF (ASSOCIATED(parent)) THEN |
---|
670 | parent_id = parent%id |
---|
671 | parent_domdesc = parent%domdesc |
---|
672 | ELSE |
---|
673 | parent_id = -1 |
---|
674 | parent_domdesc = -1 |
---|
675 | ENDIF |
---|
676 | |
---|
677 | ! provided by application, WRF defines in share/module_bc.F |
---|
678 | CALL get_bdyzone_x( bdyzone_x ) |
---|
679 | CALL get_bdyzone_y( bdyzone_y ) |
---|
680 | |
---|
681 | ALLOCATE ( new_grid ) |
---|
682 | ALLOCATE( new_grid%head_statevars ) |
---|
683 | NULLIFY( new_grid%head_statevars%next) |
---|
684 | new_grid%tail_statevars => new_grid%head_statevars |
---|
685 | |
---|
686 | ALLOCATE ( new_grid%parents( max_parents ) ) |
---|
687 | ALLOCATE ( new_grid%nests( max_nests ) ) |
---|
688 | NULLIFY( new_grid%sibling ) |
---|
689 | DO i = 1, max_nests |
---|
690 | NULLIFY( new_grid%nests(i)%ptr ) |
---|
691 | ENDDO |
---|
692 | NULLIFY (new_grid%next) |
---|
693 | NULLIFY (new_grid%same_level) |
---|
694 | NULLIFY (new_grid%i_start) |
---|
695 | NULLIFY (new_grid%j_start) |
---|
696 | NULLIFY (new_grid%i_end) |
---|
697 | NULLIFY (new_grid%j_end) |
---|
698 | ALLOCATE( new_grid%domain_clock ) |
---|
699 | new_grid%domain_clock_created = .FALSE. |
---|
700 | ALLOCATE( new_grid%alarms( MAX_WRF_ALARMS ) ) ! initialize in setup_timekeeping |
---|
701 | ALLOCATE( new_grid%alarms_created( MAX_WRF_ALARMS ) ) |
---|
702 | DO i = 1, MAX_WRF_ALARMS |
---|
703 | new_grid%alarms_created( i ) = .FALSE. |
---|
704 | ENDDO |
---|
705 | new_grid%time_set = .FALSE. |
---|
706 | new_grid%is_intermediate = .FALSE. |
---|
707 | new_grid%have_displayed_alloc_stats = .FALSE. |
---|
708 | |
---|
709 | ! set up the pointers that represent the nest hierarchy |
---|
710 | ! set this up *prior* to calling the patching or allocation |
---|
711 | ! routines so that implementations of these routines can |
---|
712 | ! traverse the nest hierarchy (through the root head_grid) |
---|
713 | ! if they need to |
---|
714 | |
---|
715 | |
---|
716 | IF ( domain_id .NE. 1 ) THEN |
---|
717 | new_grid%parents(1)%ptr => parent |
---|
718 | new_grid%num_parents = 1 |
---|
719 | parent%nests(kid)%ptr => new_grid |
---|
720 | new_grid%child_of_parent(1) = kid ! note assumption that nest can have only 1 parent |
---|
721 | parent%num_nests = parent%num_nests + 1 |
---|
722 | END IF |
---|
723 | new_grid%id = domain_id ! this needs to be assigned prior to calling wrf_patch_domain |
---|
724 | |
---|
725 | CALL wrf_patch_domain( domain_id , new_domdesc , parent, parent_id, parent_domdesc , & |
---|
726 | |
---|
727 | sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & ! z-xpose dims |
---|
728 | sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & ! (standard) |
---|
729 | sd3 , ed3 , sp3 , ep3 , sm3 , em3 , & |
---|
730 | |
---|
731 | sp1x , ep1x , sm1x , em1x , & ! x-xpose dims |
---|
732 | sp2x , ep2x , sm2x , em2x , & |
---|
733 | sp3x , ep3x , sm3x , em3x , & |
---|
734 | |
---|
735 | sp1y , ep1y , sm1y , em1y , & ! y-xpose dims |
---|
736 | sp2y , ep2y , sm2y , em2y , & |
---|
737 | sp3y , ep3y , sm3y , em3y , & |
---|
738 | |
---|
739 | bdyzone_x , bdyzone_y , new_grid%bdy_mask & |
---|
740 | ) |
---|
741 | |
---|
742 | |
---|
743 | new_grid%domdesc = new_domdesc |
---|
744 | new_grid%num_nests = 0 |
---|
745 | new_grid%num_siblings = 0 |
---|
746 | new_grid%num_parents = 0 |
---|
747 | new_grid%max_tiles = 0 |
---|
748 | new_grid%num_tiles_spec = 0 |
---|
749 | new_grid%nframes = 0 ! initialize the number of frames per file (array assignment) |
---|
750 | #if (EM_CORE == 1) |
---|
751 | new_grid%stepping_to_time = .FALSE. |
---|
752 | new_grid%adaptation_domain = 1 |
---|
753 | new_grid%last_step_updated = -1 |
---|
754 | #endif |
---|
755 | |
---|
756 | CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. , & |
---|
757 | sd1, ed1, sd2, ed2, sd3, ed3, & |
---|
758 | sm1, em1, sm2, em2, sm3, em3, & |
---|
759 | sp1, ep1, sp2, ep2, sp3, ep3, & |
---|
760 | sp1x, ep1x, sp2x, ep2x, sp3x, ep3x, & |
---|
761 | sp1y, ep1y, sp2y, ep2y, sp3y, ep3y, & |
---|
762 | sm1x, em1x, sm2x, em2x, sm3x, em3x, & ! x-xpose |
---|
763 | sm1y, em1y, sm2y, em2y, sm3y, em3y & ! y-xpose |
---|
764 | ) |
---|
765 | #if MOVE_NESTS |
---|
766 | !set these here, after alloc_space_field, which initializes vc_i, vc_j to zero |
---|
767 | new_grid%xi = -1.0 |
---|
768 | new_grid%xj = -1.0 |
---|
769 | new_grid%vc_i = -1.0 |
---|
770 | new_grid%vc_j = -1.0 |
---|
771 | #endif |
---|
772 | |
---|
773 | new_grid%sd31 = sd1 |
---|
774 | new_grid%ed31 = ed1 |
---|
775 | new_grid%sp31 = sp1 |
---|
776 | new_grid%ep31 = ep1 |
---|
777 | new_grid%sm31 = sm1 |
---|
778 | new_grid%em31 = em1 |
---|
779 | new_grid%sd32 = sd2 |
---|
780 | new_grid%ed32 = ed2 |
---|
781 | new_grid%sp32 = sp2 |
---|
782 | new_grid%ep32 = ep2 |
---|
783 | new_grid%sm32 = sm2 |
---|
784 | new_grid%em32 = em2 |
---|
785 | new_grid%sd33 = sd3 |
---|
786 | new_grid%ed33 = ed3 |
---|
787 | new_grid%sp33 = sp3 |
---|
788 | new_grid%ep33 = ep3 |
---|
789 | new_grid%sm33 = sm3 |
---|
790 | new_grid%em33 = em3 |
---|
791 | |
---|
792 | new_grid%sp31x = sp1x |
---|
793 | new_grid%ep31x = ep1x |
---|
794 | new_grid%sm31x = sm1x |
---|
795 | new_grid%em31x = em1x |
---|
796 | new_grid%sp32x = sp2x |
---|
797 | new_grid%ep32x = ep2x |
---|
798 | new_grid%sm32x = sm2x |
---|
799 | new_grid%em32x = em2x |
---|
800 | new_grid%sp33x = sp3x |
---|
801 | new_grid%ep33x = ep3x |
---|
802 | new_grid%sm33x = sm3x |
---|
803 | new_grid%em33x = em3x |
---|
804 | |
---|
805 | new_grid%sp31y = sp1y |
---|
806 | new_grid%ep31y = ep1y |
---|
807 | new_grid%sm31y = sm1y |
---|
808 | new_grid%em31y = em1y |
---|
809 | new_grid%sp32y = sp2y |
---|
810 | new_grid%ep32y = ep2y |
---|
811 | new_grid%sm32y = sm2y |
---|
812 | new_grid%em32y = em2y |
---|
813 | new_grid%sp33y = sp3y |
---|
814 | new_grid%ep33y = ep3y |
---|
815 | new_grid%sm33y = sm3y |
---|
816 | new_grid%em33y = em3y |
---|
817 | |
---|
818 | SELECT CASE ( model_data_order ) |
---|
819 | CASE ( DATA_ORDER_XYZ ) |
---|
820 | new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ; |
---|
821 | new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ; |
---|
822 | new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ; |
---|
823 | new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ; |
---|
824 | new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ; |
---|
825 | new_grid%em21 = em1 ; new_grid%em22 = em2 ; |
---|
826 | new_grid%sd11 = sd1 |
---|
827 | new_grid%ed11 = ed1 |
---|
828 | new_grid%sp11 = sp1 |
---|
829 | new_grid%ep11 = ep1 |
---|
830 | new_grid%sm11 = sm1 |
---|
831 | new_grid%em11 = em1 |
---|
832 | CASE ( DATA_ORDER_YXZ ) |
---|
833 | new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ; |
---|
834 | new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ; |
---|
835 | new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ; |
---|
836 | new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ; |
---|
837 | new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ; |
---|
838 | new_grid%em21 = em1 ; new_grid%em22 = em2 ; |
---|
839 | new_grid%sd11 = sd1 |
---|
840 | new_grid%ed11 = ed1 |
---|
841 | new_grid%sp11 = sp1 |
---|
842 | new_grid%ep11 = ep1 |
---|
843 | new_grid%sm11 = sm1 |
---|
844 | new_grid%em11 = em1 |
---|
845 | CASE ( DATA_ORDER_ZXY ) |
---|
846 | new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ; |
---|
847 | new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ; |
---|
848 | new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ; |
---|
849 | new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ; |
---|
850 | new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ; |
---|
851 | new_grid%em21 = em2 ; new_grid%em22 = em3 ; |
---|
852 | new_grid%sd11 = sd2 |
---|
853 | new_grid%ed11 = ed2 |
---|
854 | new_grid%sp11 = sp2 |
---|
855 | new_grid%ep11 = ep2 |
---|
856 | new_grid%sm11 = sm2 |
---|
857 | new_grid%em11 = em2 |
---|
858 | CASE ( DATA_ORDER_ZYX ) |
---|
859 | new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ; |
---|
860 | new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ; |
---|
861 | new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ; |
---|
862 | new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ; |
---|
863 | new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ; |
---|
864 | new_grid%em21 = em2 ; new_grid%em22 = em3 ; |
---|
865 | new_grid%sd11 = sd2 |
---|
866 | new_grid%ed11 = ed2 |
---|
867 | new_grid%sp11 = sp2 |
---|
868 | new_grid%ep11 = ep2 |
---|
869 | new_grid%sm11 = sm2 |
---|
870 | new_grid%em11 = em2 |
---|
871 | CASE ( DATA_ORDER_XZY ) |
---|
872 | new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ; |
---|
873 | new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ; |
---|
874 | new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ; |
---|
875 | new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ; |
---|
876 | new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ; |
---|
877 | new_grid%em21 = em1 ; new_grid%em22 = em3 ; |
---|
878 | new_grid%sd11 = sd1 |
---|
879 | new_grid%ed11 = ed1 |
---|
880 | new_grid%sp11 = sp1 |
---|
881 | new_grid%ep11 = ep1 |
---|
882 | new_grid%sm11 = sm1 |
---|
883 | new_grid%em11 = em1 |
---|
884 | CASE ( DATA_ORDER_YZX ) |
---|
885 | new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ; |
---|
886 | new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ; |
---|
887 | new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ; |
---|
888 | new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ; |
---|
889 | new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ; |
---|
890 | new_grid%em21 = em1 ; new_grid%em22 = em3 ; |
---|
891 | new_grid%sd11 = sd1 |
---|
892 | new_grid%ed11 = ed1 |
---|
893 | new_grid%sp11 = sp1 |
---|
894 | new_grid%ep11 = ep1 |
---|
895 | new_grid%sm11 = sm1 |
---|
896 | new_grid%em11 = em1 |
---|
897 | END SELECT |
---|
898 | |
---|
899 | CALL med_add_config_info_to_grid ( new_grid ) ! this is a mediation layer routine |
---|
900 | |
---|
901 | ! Some miscellaneous state that is in the Registry but not namelist data |
---|
902 | |
---|
903 | new_grid%tiled = .false. |
---|
904 | new_grid%patched = .false. |
---|
905 | NULLIFY(new_grid%mapping) |
---|
906 | |
---|
907 | ! This next set of includes causes all but the namelist_derived variables to be |
---|
908 | ! properly assigned to the new_grid record |
---|
909 | |
---|
910 | grid => new_grid |
---|
911 | |
---|
912 | ! Allocate storage for time series metadata |
---|
913 | ALLOCATE( grid%lattsloc( grid%max_ts_locs ) ) |
---|
914 | ALLOCATE( grid%lontsloc( grid%max_ts_locs ) ) |
---|
915 | ALLOCATE( grid%nametsloc( grid%max_ts_locs ) ) |
---|
916 | ALLOCATE( grid%desctsloc( grid%max_ts_locs ) ) |
---|
917 | ALLOCATE( grid%itsloc( grid%max_ts_locs ) ) |
---|
918 | ALLOCATE( grid%jtsloc( grid%max_ts_locs ) ) |
---|
919 | ALLOCATE( grid%id_tsloc( grid%max_ts_locs ) ) |
---|
920 | ALLOCATE( grid%ts_filename( grid%max_ts_locs ) ) |
---|
921 | grid%ntsloc = 0 |
---|
922 | grid%ntsloc_domain = 0 |
---|
923 | |
---|
924 | #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 | |
---|
2665 | END 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. |
---|
2675 | SUBROUTINE 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()' |
---|
2706 | END 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. |
---|
2713 | SUBROUTINE 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 |
---|
2721 | END 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 | |
---|