module_optional_si_input.F
References to this file elsewhere.
1 MODULE module_optional_si_input
2
3 INTEGER :: flag_metgrid , flag_tavgsfc , flag_psfc , flag_soilhgt
4
5 INTEGER :: flag_qv , flag_qc , flag_qr , flag_qi , flag_qs , flag_qg
6
7 INTEGER :: flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200 , &
8 flag_sm000010 , flag_sm010040 , flag_sm040100 , flag_sm100200 , flag_sm010200 , &
9 flag_sw000010 , flag_sw010040 , flag_sw040100 , flag_sw100200 , flag_sw010200
10
11 INTEGER :: flag_st000007 , flag_st007028 , flag_st028100 , flag_st100255 , &
12 flag_sm000007 , flag_sm007028 , flag_sm028100 , flag_sm100255
13
14 INTEGER :: flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , flag_soilt160 , flag_soilt300 , &
15 flag_soilm000 , flag_soilm005 , flag_soilm020 , flag_soilm040 , flag_soilm160 , flag_soilm300 , &
16 flag_soilw000 , flag_soilw005 , flag_soilw020 , flag_soilw040 , flag_soilw160 , flag_soilw300
17
18 INTEGER :: flag_sst , flag_toposoil , flag_snowh
19
20 INTEGER :: num_st_levels_input , num_sm_levels_input , num_sw_levels_input
21 INTEGER :: num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc
22 INTEGER , DIMENSION(100) :: st_levels_input , sm_levels_input , sw_levels_input
23 REAL , ALLOCATABLE , DIMENSION(:,:,:) :: st_input , sm_input , sw_input
24
25 CHARACTER (LEN=8) , PRIVATE :: flag_name
26
27 LOGICAL :: already_been_here
28
29 CONTAINS
30
31 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
32
33 SUBROUTINE init_module_optional_si_input ( grid , config_flags )
34
35 USE module_domain
36 USE module_configure
37
38 IMPLICIT NONE
39
40 TYPE ( domain ) :: grid
41 TYPE (grid_config_rec_type) :: config_flags
42
43 INTEGER :: ids, ide, jds, jde, kds, kde, &
44 ims, ime, jms, jme, kms, kme, &
45 its, ite, jts, jte, kts, kte
46
47 ! Get the various indices, assume XZY ordering.
48
49 ids = grid%sd31 ; ide = grid%ed31 ;
50 kds = grid%sd32 ; kde = grid%ed32 ;
51 jds = grid%sd33 ; jde = grid%ed33 ;
52
53 ims = grid%sm31 ; ime = grid%em31 ;
54 kms = grid%sm32 ; kme = grid%em32 ;
55 jms = grid%sm33 ; jme = grid%em33 ;
56
57 its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch
58 kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch
59 jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch
60
61 IF ( .NOT. already_been_here ) THEN
62
63 num_st_levels_alloc = config_flags%num_soil_layers * 3 ! used to be 2
64 num_sm_levels_alloc = config_flags%num_soil_layers * 3
65 num_sw_levels_alloc = config_flags%num_soil_layers * 3
66
67 IF ( ALLOCATED ( st_input ) ) DEALLOCATE ( st_input )
68 IF ( ALLOCATED ( sm_input ) ) DEALLOCATE ( sm_input )
69 IF ( ALLOCATED ( sw_input ) ) DEALLOCATE ( sw_input )
70
71 ALLOCATE ( st_input(ims:ime,num_st_levels_alloc,jms:jme) )
72 ALLOCATE ( sm_input(ims:ime,num_sm_levels_alloc,jms:jme) )
73 ALLOCATE ( sw_input(ims:ime,num_sw_levels_alloc,jms:jme) )
74
75 END IF
76
77 already_been_here = .TRUE.
78
79 END SUBROUTINE init_module_optional_si_input
80
81 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
82
83 SUBROUTINE optional_si_input ( grid , fid )
84
85 USE module_configure
86 USE module_domain
87
88 IMPLICIT NONE
89
90 TYPE ( domain ) :: grid
91 INTEGER , INTENT(IN) :: fid
92
93 INTEGER :: ids, ide, jds, jde, kds, kde, &
94 ims, ime, jms, jme, kms, kme, &
95 its, ite, jts, jte, kts, kte
96
97 ! Get the various indices, assume XZY ordering.
98
99 ids = grid%sd31 ; ide = grid%ed31 ;
100 kds = grid%sd32 ; kde = grid%ed32 ;
101 jds = grid%sd33 ; jde = grid%ed33 ;
102
103 ims = grid%sm31 ; ime = grid%em31 ;
104 kms = grid%sm32 ; kme = grid%em32 ;
105 jms = grid%sm33 ; jme = grid%em33 ;
106
107 its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch
108 kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch
109 jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch
110
111
112 CALL optional_tavgsfc ( grid , fid , &
113 ids, ide, jds, jde, kds, kde, &
114 ims, ime, jms, jme, kms, kme, &
115 its, ite, jts, jte, kts, kte )
116
117 CALL optional_moist ( grid , fid , &
118 ids, ide, jds, jde, kds, kde, &
119 ims, ime, jms, jme, kms, kme, &
120 its, ite, jts, jte, kts, kte )
121
122 CALL optional_metgrid ( grid , fid , &
123 ids, ide, jds, jde, kds, kde, &
124 ims, ime, jms, jme, kms, kme, &
125 its, ite, jts, jte, kts, kte )
126
127 CALL optional_sst ( grid , fid , &
128 ids, ide, jds, jde, kds, kde, &
129 ims, ime, jms, jme, kms, kme, &
130 its, ite, jts, jte, kts, kte )
131
132 CALL optional_snowh ( grid , fid , &
133 ids, ide, jds, jde, kds, kde, &
134 ims, ime, jms, jme, kms, kme, &
135 its, ite, jts, jte, kts, kte )
136
137 IF ( ( model_config_rec%sf_surface_physics(grid%id) .EQ. 1 ) .OR. &
138 ( model_config_rec%sf_surface_physics(grid%id) .EQ. 2 ) .OR. &
139 ( model_config_rec%sf_surface_physics(grid%id) .EQ. 3 ) .OR. &
140 ( model_config_rec%sf_surface_physics(grid%id) .EQ. 99 ) ) THEN
141
142 CALL optional_lsm ( grid , fid , &
143 ids, ide, jds, jde, kds, kde, &
144 ims, ime, jms, jme, kms, kme, &
145 its, ite, jts, jte, kts, kte )
146
147 CALL optional_lsm_levels ( grid , fid , &
148 ids, ide, jds, jde, kds, kde, &
149 ims, ime, jms, jme, kms, kme, &
150 its, ite, jts, jte, kts, kte )
151 END IF
152
153 END SUBROUTINE optional_si_input
154
155 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
156
157 SUBROUTINE optional_moist ( grid , fid , &
158 ids, ide, jds, jde, kds, kde, &
159 ims, ime, jms, jme, kms, kme, &
160 its, ite, jts, jte, kts, kte )
161
162 USE module_io_wrf
163 USE module_domain
164
165 USE module_configure
166 USE module_io_domain
167
168 IMPLICIT NONE
169
170 TYPE ( domain ) :: grid
171 INTEGER , INTENT(IN) :: fid
172
173 INTEGER :: ids, ide, jds, jde, kds, kde, &
174 ims, ime, jms, jme, kms, kme, &
175 its, ite, jts, jte, kts, kte
176
177 INTEGER :: itmp , icnt , ierr
178
179 flag_qv = 0
180 flag_qc = 0
181 flag_qr = 0
182 flag_qi = 0
183 flag_qs = 0
184 flag_qg = 0
185
186 flag_name(1:8) = 'QV '
187 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
188 IF ( ierr .EQ. 0 ) THEN
189 flag_qv = itmp
190 END IF
191 flag_name(1:8) = 'QC '
192 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
193 IF ( ierr .EQ. 0 ) THEN
194 flag_qc = itmp
195 END IF
196 flag_name(1:8) = 'QR '
197 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
198 IF ( ierr .EQ. 0 ) THEN
199 flag_qr = itmp
200 END IF
201 flag_name(1:8) = 'QI '
202 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
203 IF ( ierr .EQ. 0 ) THEN
204 flag_qi = itmp
205 END IF
206 flag_name(1:8) = 'QS '
207 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
208 IF ( ierr .EQ. 0 ) THEN
209 flag_qs = itmp
210 END IF
211 flag_name(1:8) = 'QG '
212 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
213 IF ( ierr .EQ. 0 ) THEN
214 flag_qg = itmp
215 END IF
216
217 END SUBROUTINE optional_moist
218
219 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
220
221 SUBROUTINE optional_metgrid ( grid , fid , &
222 ids, ide, jds, jde, kds, kde, &
223 ims, ime, jms, jme, kms, kme, &
224 its, ite, jts, jte, kts, kte )
225
226 USE module_io_wrf
227 USE module_domain
228 USE module_configure
229 USE module_io_domain
230
231 IMPLICIT NONE
232
233 TYPE ( domain ) :: grid
234 INTEGER , INTENT(IN) :: fid
235
236 INTEGER :: ids, ide, jds, jde, kds, kde, &
237 ims, ime, jms, jme, kms, kme, &
238 its, ite, jts, jte, kts, kte
239
240 INTEGER :: itmp , icnt , ierr
241
242 flag_metgrid = 0
243
244 flag_name(1:8) = 'METGRID '
245 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
246 IF ( ierr .EQ. 0 ) THEN
247 flag_metgrid = itmp
248 END IF
249
250 END SUBROUTINE optional_metgrid
251
252 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
253
254 SUBROUTINE optional_sst ( grid , fid , &
255 ids, ide, jds, jde, kds, kde, &
256 ims, ime, jms, jme, kms, kme, &
257 its, ite, jts, jte, kts, kte )
258
259 USE module_io_wrf
260 USE module_domain
261 USE module_configure
262 USE module_io_domain
263
264 IMPLICIT NONE
265
266 TYPE ( domain ) :: grid
267 INTEGER , INTENT(IN) :: fid
268
269 INTEGER :: ids, ide, jds, jde, kds, kde, &
270 ims, ime, jms, jme, kms, kme, &
271 its, ite, jts, jte, kts, kte
272
273 INTEGER :: itmp , icnt , ierr
274
275 flag_sst = 0
276
277 flag_name(1:8) = 'SST '
278 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
279 IF ( ierr .EQ. 0 ) THEN
280 flag_sst = itmp
281 END IF
282
283 END SUBROUTINE optional_sst
284
285
286 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
287
288 SUBROUTINE optional_tavgsfc ( grid , fid , &
289 ids, ide, jds, jde, kds, kde, &
290 ims, ime, jms, jme, kms, kme, &
291 its, ite, jts, jte, kts, kte )
292
293 USE module_io_wrf
294 USE module_domain
295 USE module_configure
296 USE module_io_domain
297
298 IMPLICIT NONE
299
300 TYPE ( domain ) :: grid
301 INTEGER , INTENT(IN) :: fid
302
303 INTEGER :: ids, ide, jds, jde, kds, kde, &
304 ims, ime, jms, jme, kms, kme, &
305 its, ite, jts, jte, kts, kte
306
307 INTEGER :: itmp , icnt , ierr
308
309 flag_tavgsfc = 0
310
311 flag_name(1:8) = 'TAVGSFC '
312 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
313 IF ( ierr .EQ. 0 ) THEN
314 flag_tavgsfc = itmp
315 END IF
316
317 END SUBROUTINE optional_tavgsfc
318
319 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
320
321 SUBROUTINE optional_snowh ( grid , fid , &
322 ids, ide, jds, jde, kds, kde, &
323 ims, ime, jms, jme, kms, kme, &
324 its, ite, jts, jte, kts, kte )
325
326 USE module_io_wrf
327 USE module_domain
328 USE module_configure
329 USE module_io_domain
330
331 IMPLICIT NONE
332
333 TYPE ( domain ) :: grid
334 INTEGER , INTENT(IN) :: fid
335
336 INTEGER :: ids, ide, jds, jde, kds, kde, &
337 ims, ime, jms, jme, kms, kme, &
338 its, ite, jts, jte, kts, kte
339
340 INTEGER :: itmp , icnt , ierr
341
342 flag_snowh = 0
343
344 flag_name(1:8) = 'SNOWH '
345 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
346 IF ( ierr .EQ. 0 ) THEN
347 flag_snowh = itmp
348 END IF
349
350 END SUBROUTINE optional_snowh
351
352 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
353
354 SUBROUTINE optional_lsm ( grid , fid , &
355 ids, ide, jds, jde, kds, kde, &
356 ims, ime, jms, jme, kms, kme, &
357 its, ite, jts, jte, kts, kte )
358
359 USE module_io_wrf
360 USE module_domain
361 USE module_configure
362 USE module_io_domain
363
364 IMPLICIT NONE
365
366 TYPE ( domain ) :: grid
367 INTEGER , INTENT(IN) :: fid
368
369 INTEGER :: ids, ide, jds, jde, kds, kde, &
370 ims, ime, jms, jme, kms, kme, &
371 its, ite, jts, jte, kts, kte
372
373 INTEGER :: itmp , icnt , ierr
374
375 flag_psfc = 0
376 flag_soilhgt = 0
377 flag_toposoil = 0
378
379 flag_name(1:8) = 'TOPOSOIL'
380 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
381 IF ( ierr .EQ. 0 ) THEN
382 flag_toposoil = itmp
383 END IF
384
385 flag_name(1:8) = 'PSFC '
386 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
387 IF ( ierr .EQ. 0 ) THEN
388 flag_psfc = itmp
389 END IF
390
391 flag_name(1:8) = 'SOILHGT '
392 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
393 IF ( ierr .EQ. 0 ) THEN
394 flag_soilhgt = itmp
395 END IF
396
397 END SUBROUTINE optional_lsm
398
399 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
400
401 SUBROUTINE optional_lsm_levels ( grid , fid , &
402 ids, ide, jds, jde, kds, kde, &
403 ims, ime, jms, jme, kms, kme, &
404 its, ite, jts, jte, kts, kte )
405
406 USE module_io_wrf
407 USE module_domain
408 USE module_configure
409 USE module_io_domain
410
411 IMPLICIT NONE
412
413 TYPE ( domain ) :: grid
414 INTEGER , INTENT(IN) :: fid
415
416 INTEGER :: ids, ide, jds, jde, kds, kde, &
417 ims, ime, jms, jme, kms, kme, &
418 its, ite, jts, jte, kts, kte
419
420 INTEGER :: itmp , icnt , ierr , i , j
421
422 ! Initialize the soil temp and moisture flags to "field not found".
423
424 flag_st000010 = 0
425 flag_st010040 = 0
426 flag_st040100 = 0
427 flag_st100200 = 0
428 flag_st010200 = 0
429
430 flag_sm000010 = 0
431 flag_sm010040 = 0
432 flag_sm040100 = 0
433 flag_sm100200 = 0
434 flag_sm010200 = 0
435
436 flag_sw000010 = 0
437 flag_sw010040 = 0
438 flag_sw040100 = 0
439 flag_sw100200 = 0
440 flag_sw010200 = 0
441
442 flag_st000007 = 0
443 flag_st007028 = 0
444 flag_st028100 = 0
445 flag_st100255 = 0
446
447 flag_sm000007 = 0
448 flag_sm007028 = 0
449 flag_sm028100 = 0
450 flag_sm100255 = 0
451
452 flag_soilt000 = 0
453 flag_soilt005 = 0
454 flag_soilt020 = 0
455 flag_soilt040 = 0
456 flag_soilt160 = 0
457 flag_soilt300 = 0
458
459 flag_soilm000 = 0
460 flag_soilm005 = 0
461 flag_soilm020 = 0
462 flag_soilm040 = 0
463 flag_soilm160 = 0
464 flag_soilm300 = 0
465
466 flag_soilw000 = 0
467 flag_soilw005 = 0
468 flag_soilw020 = 0
469 flag_soilw040 = 0
470 flag_soilw160 = 0
471 flag_soilw300 = 0
472
473 ! How many soil levels have we found? Well, right now, none.
474
475 num_st_levels_input = 0
476 num_sm_levels_input = 0
477 num_sw_levels_input = 0
478 st_levels_input = -1
479 sm_levels_input = -1
480 sw_levels_input = -1
481
482 flag_name(1:8) = 'ST000010'
483 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
484 IF ( ierr .EQ. 0 ) THEN
485 flag_st000010 = itmp
486 num_st_levels_input = num_st_levels_input + 1
487 st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
488 DO j = jts , MIN(jde-1,jte)
489 DO i = its , MIN(ide-1,ite)
490 st_input(i,num_st_levels_input + 1,j) = grid%st000010(i,j)
491 END DO
492 END DO
493 END IF
494 flag_name(1:8) = 'ST010040'
495 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
496 IF ( ierr .EQ. 0 ) THEN
497 flag_st010040 = itmp
498 num_st_levels_input = num_st_levels_input + 1
499 st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
500 DO j = jts , MIN(jde-1,jte)
501 DO i = its , MIN(ide-1,ite)
502 st_input(i,num_st_levels_input + 1,j) = grid%st010040(i,j)
503 END DO
504 END DO
505 END IF
506 flag_name(1:8) = 'ST040100'
507 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
508 IF ( ierr .EQ. 0 ) THEN
509 flag_st040100 = itmp
510 num_st_levels_input = num_st_levels_input + 1
511 st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
512 DO j = jts , MIN(jde-1,jte)
513 DO i = its , MIN(ide-1,ite)
514 st_input(i,num_st_levels_input + 1,j) = grid%st040100(i,j)
515 END DO
516 END DO
517 END IF
518 flag_name(1:8) = 'ST100200'
519 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
520 IF ( ierr .EQ. 0 ) THEN
521 flag_st100200 = itmp
522 num_st_levels_input = num_st_levels_input + 1
523 st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
524 DO j = jts , MIN(jde-1,jte)
525 DO i = its , MIN(ide-1,ite)
526 st_input(i,num_st_levels_input + 1,j) = grid%st100200(i,j)
527 END DO
528 END DO
529 END IF
530 flag_name(1:8) = 'ST010200'
531 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
532 IF ( ierr .EQ. 0 ) THEN
533 flag_st010200 = itmp
534 num_st_levels_input = num_st_levels_input + 1
535 st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
536 DO j = jts , MIN(jde-1,jte)
537 DO i = its , MIN(ide-1,ite)
538 st_input(i,num_st_levels_input + 1,j) = grid%st010200(i,j)
539 END DO
540 END DO
541 END IF
542 flag_name(1:8) = 'SM000010'
543 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
544 IF ( ierr .EQ. 0 ) THEN
545 flag_sm000010 = itmp
546 num_sm_levels_input = num_sm_levels_input + 1
547 sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
548 DO j = jts , MIN(jde-1,jte)
549 DO i = its , MIN(ide-1,ite)
550 sm_input(i,num_sm_levels_input + 1,j) = grid%sm000010(i,j)
551 END DO
552 END DO
553 END IF
554 flag_name(1:8) = 'SM010040'
555 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
556 IF ( ierr .EQ. 0 ) THEN
557 flag_sm010040 = itmp
558 num_sm_levels_input = num_sm_levels_input + 1
559 sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
560 DO j = jts , MIN(jde-1,jte)
561 DO i = its , MIN(ide-1,ite)
562 sm_input(i,num_sm_levels_input + 1,j) = grid%sm010040(i,j)
563 END DO
564 END DO
565 END IF
566 flag_name(1:8) = 'SM040100'
567 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
568 IF ( ierr .EQ. 0 ) THEN
569 flag_sm040100 = itmp
570 num_sm_levels_input = num_sm_levels_input + 1
571 sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
572 DO j = jts , MIN(jde-1,jte)
573 DO i = its , MIN(ide-1,ite)
574 sm_input(i,num_sm_levels_input + 1,j) = grid%sm040100(i,j)
575 END DO
576 END DO
577 END IF
578 flag_name(1:8) = 'SM100200'
579 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
580 IF ( ierr .EQ. 0 ) THEN
581 flag_sm100200 = itmp
582 num_sm_levels_input = num_sm_levels_input + 1
583 sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
584 DO j = jts , MIN(jde-1,jte)
585 DO i = its , MIN(ide-1,ite)
586 sm_input(i,num_sm_levels_input + 1,j) = grid%sm100200(i,j)
587 END DO
588 END DO
589 END IF
590 flag_name(1:8) = 'SM010200'
591 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
592 IF ( ierr .EQ. 0 ) THEN
593 flag_sm010200 = itmp
594 num_sm_levels_input = num_sm_levels_input + 1
595 sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
596 DO j = jts , MIN(jde-1,jte)
597 DO i = its , MIN(ide-1,ite)
598 sm_input(i,num_sm_levels_input + 1,j) = grid%sm010200(i,j)
599 END DO
600 END DO
601 END IF
602 flag_name(1:8) = 'SW000010'
603 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
604 IF ( ierr .EQ. 0 ) THEN
605 flag_sw000010 = itmp
606 num_sw_levels_input = num_sw_levels_input + 1
607 sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
608 DO j = jts , MIN(jde-1,jte)
609 DO i = its , MIN(ide-1,ite)
610 sw_input(i,num_sw_levels_input + 1,j) = grid%sw000010(i,j)
611 END DO
612 END DO
613 END IF
614 flag_name(1:8) = 'SW010040'
615 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
616 IF ( ierr .EQ. 0 ) THEN
617 flag_sw010040 = itmp
618 num_sw_levels_input = num_sw_levels_input + 1
619 sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
620 DO j = jts , MIN(jde-1,jte)
621 DO i = its , MIN(ide-1,ite)
622 sw_input(i,num_sw_levels_input + 1,j) = grid%sw010040(i,j)
623 END DO
624 END DO
625 END IF
626 flag_name(1:8) = 'SW040100'
627 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
628 IF ( ierr .EQ. 0 ) THEN
629 flag_sw040100 = itmp
630 num_sw_levels_input = num_sw_levels_input + 1
631 sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
632 DO j = jts , MIN(jde-1,jte)
633 DO i = its , MIN(ide-1,ite)
634 sw_input(i,num_sw_levels_input + 1,j) = grid%sw040100(i,j)
635 END DO
636 END DO
637 END IF
638 flag_name(1:8) = 'SW100200'
639 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
640 IF ( ierr .EQ. 0 ) THEN
641 flag_sw100200 = itmp
642 num_sw_levels_input = num_sw_levels_input + 1
643 sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
644 DO j = jts , MIN(jde-1,jte)
645 DO i = its , MIN(ide-1,ite)
646 sw_input(i,num_sw_levels_input + 1,j) = grid%sw100200(i,j)
647 END DO
648 END DO
649 END IF
650 flag_name(1:8) = 'SW010200'
651 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
652 IF ( ierr .EQ. 0 ) THEN
653 flag_sw010200 = itmp
654 num_sw_levels_input = num_sw_levels_input + 1
655 sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
656 DO j = jts , MIN(jde-1,jte)
657 DO i = its , MIN(ide-1,ite)
658 sw_input(i,num_sw_levels_input + 1,j) = grid%sw010200(i,j)
659 END DO
660 END DO
661 END IF
662 flag_name(1:8) = 'ST000007'
663 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
664 IF ( ierr .EQ. 0 ) THEN
665 flag_st000007 = itmp
666 num_st_levels_input = num_st_levels_input + 1
667 st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
668 DO j = jts , MIN(jde-1,jte)
669 DO i = its , MIN(ide-1,ite)
670 st_input(i,num_st_levels_input + 1,j) = grid%st000007(i,j)
671 END DO
672 END DO
673 END IF
674 flag_name(1:8) = 'ST007028'
675 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
676 IF ( ierr .EQ. 0 ) THEN
677 flag_st007028 = itmp
678 num_st_levels_input = num_st_levels_input + 1
679 st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
680 DO j = jts , MIN(jde-1,jte)
681 DO i = its , MIN(ide-1,ite)
682 st_input(i,num_st_levels_input + 1,j) = grid%st007028(i,j)
683 END DO
684 END DO
685 END IF
686 flag_name(1:8) = 'ST028100'
687 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
688 IF ( ierr .EQ. 0 ) THEN
689 flag_st028100 = itmp
690 num_st_levels_input = num_st_levels_input + 1
691 st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
692 DO j = jts , MIN(jde-1,jte)
693 DO i = its , MIN(ide-1,ite)
694 st_input(i,num_st_levels_input + 1,j) = grid%st028100(i,j)
695 END DO
696 END DO
697 END IF
698 flag_name(1:8) = 'ST100255'
699 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
700 IF ( ierr .EQ. 0 ) THEN
701 flag_st100255 = itmp
702 num_st_levels_input = num_st_levels_input + 1
703 st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
704 DO j = jts , MIN(jde-1,jte)
705 DO i = its , MIN(ide-1,ite)
706 st_input(i,num_st_levels_input + 1,j) = grid%st100255(i,j)
707 END DO
708 END DO
709 END IF
710 flag_name(1:8) = 'SM000007'
711 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
712 IF ( ierr .EQ. 0 ) THEN
713 flag_sm000007 = itmp
714 num_sm_levels_input = num_sm_levels_input + 1
715 sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
716 DO j = jts , MIN(jde-1,jte)
717 DO i = its , MIN(ide-1,ite)
718 sm_input(i,num_sm_levels_input + 1,j) = grid%sm000007(i,j)
719 END DO
720 END DO
721 END IF
722 flag_name(1:8) = 'SM007028'
723 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
724 IF ( ierr .EQ. 0 ) THEN
725 flag_sm007028 = itmp
726 num_sm_levels_input = num_sm_levels_input + 1
727 sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
728 DO j = jts , MIN(jde-1,jte)
729 DO i = its , MIN(ide-1,ite)
730 sm_input(i,num_sm_levels_input + 1,j) = grid%sm007028(i,j)
731 END DO
732 END DO
733 END IF
734 flag_name(1:8) = 'SM028100'
735 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
736 IF ( ierr .EQ. 0 ) THEN
737 flag_sm028100 = itmp
738 num_sm_levels_input = num_sm_levels_input + 1
739 sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
740 DO j = jts , MIN(jde-1,jte)
741 DO i = its , MIN(ide-1,ite)
742 sm_input(i,num_sm_levels_input + 1,j) = grid%sm028100(i,j)
743 END DO
744 END DO
745 END IF
746 flag_name(1:8) = 'SM100255'
747 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
748 IF ( ierr .EQ. 0 ) THEN
749 flag_sm100255 = itmp
750 num_sm_levels_input = num_sm_levels_input + 1
751 sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
752 DO j = jts , MIN(jde-1,jte)
753 DO i = its , MIN(ide-1,ite)
754 sm_input(i,num_sm_levels_input + 1,j) = grid%sm100255(i,j)
755 END DO
756 END DO
757 END IF
758 flag_name(1:8) = 'SOILT000'
759 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
760 IF ( ierr .EQ. 0 ) THEN
761 flag_soilt000 = itmp
762 num_st_levels_input = num_st_levels_input + 1
763 st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
764 DO j = jts , MIN(jde-1,jte)
765 DO i = its , MIN(ide-1,ite)
766 st_input(i,num_st_levels_input ,j) = grid%soilt000(i,j)
767 END DO
768 END DO
769 END IF
770 flag_name(1:8) = 'SOILT005'
771 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
772 IF ( ierr .EQ. 0 ) THEN
773 flag_soilt005 = itmp
774 num_st_levels_input = num_st_levels_input + 1
775 st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
776 DO j = jts , MIN(jde-1,jte)
777 DO i = its , MIN(ide-1,ite)
778 st_input(i,num_st_levels_input ,j) = grid%soilt005(i,j)
779 END DO
780 END DO
781 END IF
782 flag_name(1:8) = 'SOILT020'
783 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
784 IF ( ierr .EQ. 0 ) THEN
785 flag_soilt020 = itmp
786 num_st_levels_input = num_st_levels_input + 1
787 st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
788 DO j = jts , MIN(jde-1,jte)
789 DO i = its , MIN(ide-1,ite)
790 st_input(i,num_st_levels_input ,j) = grid%soilt020(i,j)
791 END DO
792 END DO
793 END IF
794 flag_name(1:8) = 'SOILT040'
795 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
796 IF ( ierr .EQ. 0 ) THEN
797 flag_soilt040 = itmp
798 num_st_levels_input = num_st_levels_input + 1
799 st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
800 DO j = jts , MIN(jde-1,jte)
801 DO i = its , MIN(ide-1,ite)
802 st_input(i,num_st_levels_input ,j) = grid%soilt040(i,j)
803 END DO
804 END DO
805 END IF
806 flag_name(1:8) = 'SOILT160'
807 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
808 IF ( ierr .EQ. 0 ) THEN
809 flag_soilt160 = itmp
810 num_st_levels_input = num_st_levels_input + 1
811 st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
812 DO j = jts , MIN(jde-1,jte)
813 DO i = its , MIN(ide-1,ite)
814 st_input(i,num_st_levels_input ,j) = grid%soilt160(i,j)
815 END DO
816 END DO
817 END IF
818 flag_name(1:8) = 'SOILT300'
819 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
820 IF ( ierr .EQ. 0 ) THEN
821 flag_soilt300 = itmp
822 num_st_levels_input = num_st_levels_input + 1
823 st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
824 DO j = jts , MIN(jde-1,jte)
825 DO i = its , MIN(ide-1,ite)
826 st_input(i,num_st_levels_input ,j) = grid%soilt300(i,j)
827 END DO
828 END DO
829 END IF
830 flag_name(1:8) = 'SOILM000'
831 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
832 IF ( ierr .EQ. 0 ) THEN
833 flag_soilm000 = itmp
834 num_sm_levels_input = num_sm_levels_input + 1
835 sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
836 DO j = jts , MIN(jde-1,jte)
837 DO i = its , MIN(ide-1,ite)
838 sm_input(i,num_sm_levels_input ,j) = grid%soilm000(i,j)
839 END DO
840 END DO
841 END IF
842 flag_name(1:8) = 'SOILM005'
843 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
844 IF ( ierr .EQ. 0 ) THEN
845 flag_soilm005 = itmp
846 num_sm_levels_input = num_sm_levels_input + 1
847 sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
848 DO j = jts , MIN(jde-1,jte)
849 DO i = its , MIN(ide-1,ite)
850 sm_input(i,num_sm_levels_input ,j) = grid%soilm005(i,j)
851 END DO
852 END DO
853 END IF
854 flag_name(1:8) = 'SOILM020'
855 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
856 IF ( ierr .EQ. 0 ) THEN
857 flag_soilm020 = itmp
858 num_sm_levels_input = num_sm_levels_input + 1
859 sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
860 DO j = jts , MIN(jde-1,jte)
861 DO i = its , MIN(ide-1,ite)
862 sm_input(i,num_sm_levels_input ,j) = grid%soilm020(i,j)
863 END DO
864 END DO
865 END IF
866 flag_name(1:8) = 'SOILM040'
867 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
868 IF ( ierr .EQ. 0 ) THEN
869 flag_soilm040 = itmp
870 num_sm_levels_input = num_sm_levels_input + 1
871 sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
872 DO j = jts , MIN(jde-1,jte)
873 DO i = its , MIN(ide-1,ite)
874 sm_input(i,num_sm_levels_input ,j) = grid%soilm040(i,j)
875 END DO
876 END DO
877 END IF
878 flag_name(1:8) = 'SOILM160'
879 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
880 IF ( ierr .EQ. 0 ) THEN
881 flag_soilm160 = itmp
882 num_sm_levels_input = num_sm_levels_input + 1
883 sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
884 DO j = jts , MIN(jde-1,jte)
885 DO i = its , MIN(ide-1,ite)
886 sm_input(i,num_sm_levels_input ,j) = grid%soilm160(i,j)
887 END DO
888 END DO
889 END IF
890 flag_name(1:8) = 'SOILM300'
891 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
892 IF ( ierr .EQ. 0 ) THEN
893 flag_soilm300 = itmp
894 num_sm_levels_input = num_sm_levels_input + 1
895 sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
896 DO j = jts , MIN(jde-1,jte)
897 DO i = its , MIN(ide-1,ite)
898 sm_input(i,num_sm_levels_input ,j) = grid%soilm300(i,j)
899 END DO
900 END DO
901 END IF
902 flag_name(1:8) = 'SOILW000'
903 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
904 IF ( ierr .EQ. 0 ) THEN
905 flag_soilw000 = itmp
906 num_sw_levels_input = num_sw_levels_input + 1
907 sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
908 DO j = jts , MIN(jde-1,jte)
909 DO i = its , MIN(ide-1,ite)
910 sw_input(i,num_sw_levels_input ,j) = grid%soilw000(i,j)
911 END DO
912 END DO
913 END IF
914 flag_name(1:8) = 'SOILW005'
915 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
916 IF ( ierr .EQ. 0 ) THEN
917 flag_soilw005 = itmp
918 num_sw_levels_input = num_sw_levels_input + 1
919 sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
920 DO j = jts , MIN(jde-1,jte)
921 DO i = its , MIN(ide-1,ite)
922 sw_input(i,num_sw_levels_input ,j) = grid%soilw005(i,j)
923 END DO
924 END DO
925 END IF
926 flag_name(1:8) = 'SOILW020'
927 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
928 IF ( ierr .EQ. 0 ) THEN
929 flag_soilw020 = itmp
930 num_sw_levels_input = num_sw_levels_input + 1
931 sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
932 DO j = jts , MIN(jde-1,jte)
933 DO i = its , MIN(ide-1,ite)
934 sw_input(i,num_sw_levels_input ,j) = grid%soilw020(i,j)
935 END DO
936 END DO
937 END IF
938 flag_name(1:8) = 'SOILW040'
939 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
940 IF ( ierr .EQ. 0 ) THEN
941 flag_soilw040 = itmp
942 num_sw_levels_input = num_sw_levels_input + 1
943 sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
944 DO j = jts , MIN(jde-1,jte)
945 DO i = its , MIN(ide-1,ite)
946 sw_input(i,num_sw_levels_input ,j) = grid%soilw040(i,j)
947 END DO
948 END DO
949 END IF
950 flag_name(1:8) = 'SOILW160'
951 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
952 IF ( ierr .EQ. 0 ) THEN
953 flag_soilw160 = itmp
954 num_sw_levels_input = num_sw_levels_input + 1
955 sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
956 DO j = jts , MIN(jde-1,jte)
957 DO i = its , MIN(ide-1,ite)
958 sw_input(i,num_sw_levels_input ,j) = grid%soilw160(i,j)
959 END DO
960 END DO
961 END IF
962 flag_name(1:8) = 'SOILW300'
963 CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
964 IF ( ierr .EQ. 0 ) THEN
965 flag_soilw300 = itmp
966 num_sw_levels_input = num_sw_levels_input + 1
967 sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
968 DO j = jts , MIN(jde-1,jte)
969 DO i = its , MIN(ide-1,ite)
970 sw_input(i,num_sw_levels_input ,j) = grid%soilw300(i,j)
971 END DO
972 END DO
973 END IF
974
975 ! OK, let's do a quick sanity check.
976
977 IF ( ( num_st_levels_input .GT. num_st_levels_alloc ) .OR. &
978 ( num_sm_levels_input .GT. num_sm_levels_alloc ) .OR. &
979 ( num_sw_levels_input .GT. num_sw_levels_alloc ) ) THEN
980 print *,'pain and woe, the soil level allocation is too small'
981 CALL wrf_error_fatal ( 'soil_levels_too_few' )
982 END IF
983
984 END SUBROUTINE optional_lsm_levels
985
986 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
987
988 FUNCTION char2int1( string3 ) RESULT ( int1 )
989 CHARACTER (LEN=3) , INTENT(IN) :: string3
990 INTEGER :: i1 , int1
991 READ(string3,fmt='(I3)') i1
992 int1 = i1
993 END FUNCTION char2int1
994
995 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
996
997 FUNCTION char2int2( string6 ) RESULT ( int1 )
998 CHARACTER (LEN=6) , INTENT(IN) :: string6
999 INTEGER :: i2 , i1 , int1
1000 READ(string6,fmt='(I3,I3)') i1,i2
1001 int1 = ( i2 + i1 ) / 2
1002 END FUNCTION char2int2
1003
1004 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1005
1006 END MODULE module_optional_si_input