source: lmdz_wrf/trunk/WRFV3/share/module_optional_input.F @ 1531

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

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 55.1 KB
Line 
1MODULE module_optional_input
2
3   INTEGER :: flag_metgrid  , flag_tavgsfc  , flag_psfc     , flag_soilhgt  , flag_mf_xy , flag_slp , &
4              flag_snow     , flag_snowh    , flag_tsk      , flag_pinterp
5
6   INTEGER :: flag_qv       , flag_qc       , flag_qr       , flag_qi       , flag_qs       , &
7              flag_qg       , flag_qh       , flag_qni      , flag_sh
8
9   INTEGER :: flag_soil_levels, flag_soil_layers
10
11   INTEGER :: flag_st000010 , flag_st010040 , flag_st040100 , flag_st100200 , flag_st010200 , &
12              flag_sm000010 , flag_sm010040 , flag_sm040100 , flag_sm100200 , flag_sm010200 , &
13              flag_sw000010 , flag_sw010040 , flag_sw040100 , flag_sw100200 , flag_sw010200
14
15   INTEGER :: flag_st000007 , flag_st007028 , flag_st028100 , flag_st100255 , &
16              flag_sm000007 , flag_sm007028 , flag_sm028100 , flag_sm100255
17
18   INTEGER :: flag_soilt000 , flag_soilt005 , flag_soilt020 , flag_soilt040 , flag_soilt160 , flag_soilt300 , &
19              flag_soilm000 , flag_soilm005 , flag_soilm020 , flag_soilm040 , flag_soilm160 , flag_soilm300 , &
20              flag_soilw000 , flag_soilw005 , flag_soilw020 , flag_soilw040 , flag_soilw160 , flag_soilw300
21
22   INTEGER :: flag_sst      , flag_toposoil
23
24   INTEGER :: flag_icedepth , flag_icefrac
25
26   INTEGER :: flag_ptheta
27
28   INTEGER :: flag_excluded_middle
29
30   INTEGER                  :: num_soil_levels_input
31   INTEGER                  :: num_st_levels_input , num_sm_levels_input , num_sw_levels_input
32   INTEGER                  :: num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc
33   INTEGER , DIMENSION(100) ::     st_levels_input ,     sm_levels_input ,     sw_levels_input
34   REAL , ALLOCATABLE , DIMENSION(:,:,:) :: st_input , sm_input , sw_input
35
36   CHARACTER (LEN=80) , PRIVATE :: flag_name
37 
38   LOGICAL :: already_been_here
39
40CONTAINS
41
42!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
43
44   SUBROUTINE init_module_optional_input ( grid , config_flags )
45
46      USE module_domain , ONLY : domain
47      USE module_configure , ONLY : grid_config_rec_type
48
49      IMPLICIT NONE
50
51      TYPE ( domain ) :: grid
52      TYPE (grid_config_rec_type) :: config_flags
53
54      INTEGER :: ids, ide, jds, jde, kds, kde, &
55                 ims, ime, jms, jme, kms, kme, &
56                 its, ite, jts, jte, kts, kte
57
58      !  Get the various indices, assume XYZ & XZY ordering.
59#if (NMM_CORE==1)
60      ids = grid%sd31 ; ide = grid%ed31 ;
61      jds = grid%sd32 ; jde = grid%ed32 ;
62      kds = grid%sd33 ; kde = grid%ed33 ;
63
64      ims = grid%sm31 ; ime = grid%em31 ;
65      jms = grid%sm32 ; jme = grid%em32 ;
66      kms = grid%sm33 ; kme = grid%em33 ;
67
68      its = grid%sp31 ; ite = grid%ep31 ;   ! note that tile is entire patch
69      jts = grid%sp32 ; jte = grid%ep32 ;   ! note that tile is entire patch
70      kts = grid%sp33 ; kte = grid%ep33 ;   ! note that tile is entire patch
71#endif
72#if (EM_CORE==1)
73      ids = grid%sd31 ; ide = grid%ed31 ;
74      kds = grid%sd32 ; kde = grid%ed32 ;
75      jds = grid%sd33 ; jde = grid%ed33 ;
76
77      ims = grid%sm31 ; ime = grid%em31 ;
78      kms = grid%sm32 ; kme = grid%em32 ;
79      jms = grid%sm33 ; jme = grid%em33 ;
80
81      its = grid%sp31 ; ite = grid%ep31 ;   ! note that tile is entire patch
82      kts = grid%sp32 ; kte = grid%ep32 ;   ! note that tile is entire patch
83      jts = grid%sp33 ; jte = grid%ep33 ;   ! note that tile is entire patch
84#endif
85      IF ( .NOT. already_been_here ) THEN
86
87         num_st_levels_alloc = config_flags%num_soil_layers * 3 ! used to be 2
88         num_sm_levels_alloc = config_flags%num_soil_layers * 3
89         num_sw_levels_alloc = config_flags%num_soil_layers * 3
90
91         IF ( ALLOCATED ( st_input ) ) DEALLOCATE ( st_input )
92         IF ( ALLOCATED ( sm_input ) ) DEALLOCATE ( sm_input )
93         IF ( ALLOCATED ( sw_input ) ) DEALLOCATE ( sw_input )
94   
95         ALLOCATE ( st_input(ims:ime,num_st_levels_alloc,jms:jme) )
96         ALLOCATE ( sm_input(ims:ime,num_sm_levels_alloc,jms:jme) )
97         ALLOCATE ( sw_input(ims:ime,num_sw_levels_alloc,jms:jme) )
98
99      END IF
100
101      already_been_here = .TRUE.
102
103   END SUBROUTINE init_module_optional_input
104
105#if (DA_CORE != 1)
106!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
107
108   SUBROUTINE optional_input ( grid , fid, config_flags )
109
110      USE module_io_domain
111      USE module_configure       , ONLY : grid_config_rec_type
112      USE module_domain , ONLY : domain
113
114      IMPLICIT NONE
115
116      TYPE ( domain ) :: grid
117      TYPE (grid_config_rec_type) :: config_flags
118      INTEGER , INTENT(IN) :: fid
119
120      INTEGER :: ids, ide, jds, jde, kds, kde, &
121                 ims, ime, jms, jme, kms, kme, &
122                 its, ite, jts, jte, kts, kte
123
124      INTEGER :: itmp , icnt , ierr, num_layers
125      CHARACTER (LEN=132) :: message
126
127      !  Get the various indices, assume XYZ & XZY ordering.
128#if (NMM_CORE==1)
129      ids = grid%sd31 ; ide = grid%ed31 ;
130      jds = grid%sd32 ; jde = grid%ed32 ;
131      kds = grid%sd33 ; kde = grid%ed33 ;
132
133      ims = grid%sm31 ; ime = grid%em31 ;
134      jms = grid%sm32 ; jme = grid%em32 ;
135      kms = grid%sm33 ; kme = grid%em33 ;
136
137      its = grid%sp31 ; ite = grid%ep31 ;   ! note that tile is entire patch
138      jts = grid%sp32 ; jte = grid%ep32 ;   ! note that tile is entire patch
139      kts = grid%sp33 ; kte = grid%ep33 ;   ! note that tile is entire patch
140#endif
141#if (EM_CORE==1)
142      ids = grid%sd31 ; ide = grid%ed31 ;
143      kds = grid%sd32 ; kde = grid%ed32 ;
144      jds = grid%sd33 ; jde = grid%ed33 ;
145
146      ims = grid%sm31 ; ime = grid%em31 ;
147      kms = grid%sm32 ; kme = grid%em32 ;
148      jms = grid%sm33 ; jme = grid%em33 ;
149
150      its = grid%sp31 ; ite = grid%ep31 ;   ! note that tile is entire patch
151      kts = grid%sp32 ; kte = grid%ep32 ;   ! note that tile is entire patch
152      jts = grid%sp33 ; jte = grid%ep33 ;   ! note that tile is entire patch
153#endif
154
155      CALL optional_tsk        ( grid , fid , &
156                                 ids, ide, jds, jde, kds, kde, &
157                                 ims, ime, jms, jme, kms, kme, &
158                                 its, ite, jts, jte, kts, kte  )
159
160      CALL optional_tavgsfc    ( grid , fid , &
161                                 ids, ide, jds, jde, kds, kde, &
162                                 ims, ime, jms, jme, kms, kme, &
163                                 its, ite, jts, jte, kts, kte  )
164
165      CALL optional_moist      ( grid , fid , &
166                                 ids, ide, jds, jde, kds, kde, &
167                                 ims, ime, jms, jme, kms, kme, &
168                                 its, ite, jts, jte, kts, kte  )
169
170      CALL optional_metgrid    ( grid , fid , &
171                                 ids, ide, jds, jde, kds, kde, &
172                                 ims, ime, jms, jme, kms, kme, &
173                                 its, ite, jts, jte, kts, kte  )
174
175      CALL optional_sst        ( grid , fid , &
176                                 ids, ide, jds, jde, kds, kde, &
177                                 ims, ime, jms, jme, kms, kme, &
178                                 its, ite, jts, jte, kts, kte  )
179
180      CALL optional_snowh      ( grid , fid , &
181                                 ids, ide, jds, jde, kds, kde, &
182                                 ims, ime, jms, jme, kms, kme, &
183                                 its, ite, jts, jte, kts, kte  )
184
185
186      CALL optional_sfc        ( grid , fid , &
187                                 ids, ide, jds, jde, kds, kde, &
188                                 ims, ime, jms, jme, kms, kme, &
189                                 its, ite, jts, jte, kts, kte  )
190
191      CALL optional_ice        ( grid , fid , &
192                                 ids, ide, jds, jde, kds, kde, &
193                                 ims, ime, jms, jme, kms, kme, &
194                                 its, ite, jts, jte, kts, kte  )
195
196      CALL optional_ptheta     ( grid , fid , &
197                                 ids, ide, jds, jde, kds, kde, &
198                                 ims, ime, jms, jme, kms, kme, &
199                                 its, ite, jts, jte, kts, kte  )
200
201      CALL optional_excl_middle( grid , fid , &
202                                 ids, ide, jds, jde, kds, kde, &
203                                 ims, ime, jms, jme, kms, kme, &
204                                 its, ite, jts, jte, kts, kte  )
205
206      flag_soil_levels = 0
207      flag_soil_layers = 0
208
209      !  How many soil levels have we found?  Well, right now, none.
210
211      num_st_levels_input = 0
212      num_sm_levels_input = 0
213      num_sw_levels_input = 0
214
215      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_SOIL_LEVELS', itmp, 1, icnt, ierr )
216
217      IF ( ierr .EQ. 0 ) THEN
218         flag_soil_levels = itmp
219         write (message,'(A50,I3)') 'flag_soil_levels read from met_em file is',flag_soil_levels
220         CALL wrf_debug(0,message)
221      END IF
222
223      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_SOIL_LAYERS', itmp, 1, icnt, ierr )
224
225      IF ( ierr .EQ. 0 ) THEN
226         flag_soil_layers = itmp
227         write (message,'(A50,I3)') 'flag_soil_layers read from met_em file is',flag_soil_layers
228         CALL wrf_debug(0,message)
229      END IF
230
231#if (EM_CORE == 1)
232      IF ( ( flag_soil_levels == 1 ) .OR. ( flag_soil_layers == 1 ) ) THEN
233
234         num_st_levels_input   = config_flags%num_metgrid_soil_levels
235         num_sm_levels_input   = config_flags%num_metgrid_soil_levels
236         num_sw_levels_input   = config_flags%num_metgrid_soil_levels
237         num_soil_levels_input = config_flags%num_metgrid_soil_levels
238
239      END IF
240#endif
241
242      IF (  ( model_config_rec%sf_surface_physics(grid%id) .EQ. 1 ) .OR. &
243            ( model_config_rec%sf_surface_physics(grid%id) .EQ. 2 ) .OR. &
244            ( model_config_rec%sf_surface_physics(grid%id) .EQ. 3 ) .OR. &
245            ( model_config_rec%sf_surface_physics(grid%id) .EQ. 7 ) .OR. &
246            ( model_config_rec%sf_surface_physics(grid%id) .EQ. 88 ) ) THEN
247   
248         CALL optional_lsm_levels ( grid , fid , &
249                                    ids, ide, jds, jde, kds, kde, &
250                                    ims, ime, jms, jme, kms, kme, &
251                                    its, ite, jts, jte, kts, kte  )
252      END IF
253     
254   END SUBROUTINE optional_input
255
256!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
257
258   SUBROUTINE optional_moist ( grid , fid , &
259                               ids, ide, jds, jde, kds, kde, &
260                               ims, ime, jms, jme, kms, kme, &
261                               its, ite, jts, jte, kts, kte  )
262
263      USE module_io_wrf
264      USE module_domain , ONLY : domain
265
266USE module_configure , ONLY : grid_config_rec_type
267USE module_io_domain
268
269      IMPLICIT NONE
270
271      TYPE ( domain ) :: grid
272      INTEGER , INTENT(IN) :: fid
273
274      INTEGER :: ids, ide, jds, jde, kds, kde, &
275                 ims, ime, jms, jme, kms, kme, &
276                 its, ite, jts, jte, kts, kte
277
278      INTEGER :: itmp , icnt , ierr
279
280      flag_name = '                                                                                '
281
282      flag_qv       = 0
283      flag_qc       = 0
284      flag_qr       = 0
285      flag_qi       = 0
286      flag_qs       = 0
287      flag_qg       = 0
288      flag_qh       = 0
289      flag_qni      = 0
290      flag_sh       = 0
291
292      flag_name(1:8) = 'QV      '
293      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
294      IF ( ierr .EQ. 0 ) THEN
295         flag_qv       = itmp
296      END IF
297      flag_name(1:8) = 'QC      '
298      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
299      IF ( ierr .EQ. 0 ) THEN
300         flag_qc       = itmp
301      END IF
302      flag_name(1:8) = 'QR      '
303      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
304      IF ( ierr .EQ. 0 ) THEN
305         flag_qr       = itmp
306      END IF
307      flag_name(1:8) = 'QI      '
308      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
309      IF ( ierr .EQ. 0 ) THEN
310         flag_qi       = itmp
311      END IF
312      flag_name(1:8) = 'QS      '
313      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
314      IF ( ierr .EQ. 0 ) THEN
315         flag_qs       = itmp
316      END IF
317      flag_name(1:8) = 'QG      '
318      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
319      IF ( ierr .EQ. 0 ) THEN
320         flag_qg       = itmp
321      END IF
322      flag_name(1:8) = 'QH      '
323      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
324      IF ( ierr .EQ. 0 ) THEN
325         flag_qh       = itmp
326      END IF
327      flag_name(1:8) = 'QNI      '
328      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
329      IF ( ierr .EQ. 0 ) THEN
330         flag_qni       = itmp
331      END IF
332      flag_name(1:8) = 'SH      '
333      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
334      IF ( ierr .EQ. 0 ) THEN
335         flag_sh       = itmp
336      END IF
337   
338   END SUBROUTINE optional_moist
339
340!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
341
342   SUBROUTINE optional_metgrid ( grid , fid , &
343                                 ids, ide, jds, jde, kds, kde, &
344                                 ims, ime, jms, jme, kms, kme, &
345                                 its, ite, jts, jte, kts, kte  )
346
347      USE module_io_wrf
348      USE module_domain , ONLY : domain
349USE module_configure , ONLY : grid_config_rec_type
350USE module_io_domain
351
352      IMPLICIT NONE
353
354      TYPE ( domain ) :: grid
355      INTEGER , INTENT(IN) :: fid
356
357      INTEGER :: ids, ide, jds, jde, kds, kde, &
358                 ims, ime, jms, jme, kms, kme, &
359                 its, ite, jts, jte, kts, kte
360
361      INTEGER :: itmp , icnt , ierr
362
363      flag_name = '                                                                                '
364
365      flag_metgrid = 0
366
367      flag_name(1:8) = 'METGRID '
368      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
369      IF ( ierr .EQ. 0 ) THEN
370         flag_metgrid  = itmp
371      END IF
372
373      flag_pinterp = 0
374
375      flag_name(1:8) = 'P_INTERP'
376      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
377      IF ( ierr .EQ. 0 ) THEN
378         flag_pinterp  = itmp
379      END IF
380
381      flag_mf_xy = 0
382
383      flag_name(1:8) = 'MF_XY   '
384      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
385      IF ( ierr .EQ. 0 ) THEN
386         flag_mf_xy    = itmp
387      END IF
388   
389      grid%flag_metgrid = flag_metgrid
390      grid%flag_mf_xy   = flag_mf_xy
391   END SUBROUTINE optional_metgrid
392
393!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
394
395   SUBROUTINE optional_sst ( grid , fid , &
396                             ids, ide, jds, jde, kds, kde, &
397                             ims, ime, jms, jme, kms, kme, &
398                             its, ite, jts, jte, kts, kte  )
399
400      USE module_io_wrf
401      USE module_domain , ONLY : domain
402USE module_configure , ONLY : grid_config_rec_type
403USE module_io_domain
404
405      IMPLICIT NONE
406
407      TYPE ( domain ) :: grid
408      INTEGER , INTENT(IN) :: fid
409
410      INTEGER :: ids, ide, jds, jde, kds, kde, &
411                 ims, ime, jms, jme, kms, kme, &
412                 its, ite, jts, jte, kts, kte
413
414      INTEGER :: itmp , icnt , ierr
415
416      flag_name = '                                                                                '
417
418      flag_sst      = 0
419
420      flag_name(1:8) = 'SST     '
421      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
422      IF ( ierr .EQ. 0 ) THEN
423         flag_sst      = itmp
424      END IF
425   
426   END SUBROUTINE optional_sst
427
428!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
429
430   SUBROUTINE optional_tsk     ( grid , fid , &
431                                 ids, ide, jds, jde, kds, kde, &
432                                 ims, ime, jms, jme, kms, kme, &
433                                 its, ite, jts, jte, kts, kte  )
434
435      USE module_io_wrf
436      USE module_domain , ONLY : domain
437USE module_configure , ONLY : grid_config_rec_type
438USE module_io_domain
439
440      IMPLICIT NONE
441
442      TYPE ( domain ) :: grid
443      INTEGER , INTENT(IN) :: fid
444
445      INTEGER :: ids, ide, jds, jde, kds, kde, &
446                 ims, ime, jms, jme, kms, kme, &
447                 its, ite, jts, jte, kts, kte
448
449      INTEGER :: itmp , icnt , ierr
450
451      flag_name = '                                                                                '
452
453      flag_tsk      = 0
454
455      flag_name(1:8) = 'TSK     '
456      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
457      IF ( ierr .EQ. 0 ) THEN
458         flag_tsk      = itmp
459      END IF
460   
461   END SUBROUTINE optional_tsk
462
463!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
464
465   SUBROUTINE optional_tavgsfc ( grid , fid , &
466                                 ids, ide, jds, jde, kds, kde, &
467                                 ims, ime, jms, jme, kms, kme, &
468                                 its, ite, jts, jte, kts, kte  )
469
470      USE module_io_wrf
471      USE module_domain , ONLY : domain
472USE module_configure , ONLY : grid_config_rec_type
473USE module_io_domain
474
475      IMPLICIT NONE
476
477      TYPE ( domain ) :: grid
478      INTEGER , INTENT(IN) :: fid
479
480      INTEGER :: ids, ide, jds, jde, kds, kde, &
481                 ims, ime, jms, jme, kms, kme, &
482                 its, ite, jts, jte, kts, kte
483
484      INTEGER :: itmp , icnt , ierr
485
486      flag_name = '                                                                                '
487
488      flag_tavgsfc  = 0
489
490      flag_name(1:8) = 'TAVGSFC '
491      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
492      IF ( ierr .EQ. 0 ) THEN
493         flag_tavgsfc  = itmp
494      END IF
495   
496   END SUBROUTINE optional_tavgsfc
497
498!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
499
500   SUBROUTINE optional_snowh ( grid , fid , &
501                               ids, ide, jds, jde, kds, kde, &
502                               ims, ime, jms, jme, kms, kme, &
503                               its, ite, jts, jte, kts, kte  )
504
505      USE module_io_wrf
506      USE module_domain , ONLY : domain
507USE module_configure , ONLY : grid_config_rec_type
508USE module_io_domain
509
510      IMPLICIT NONE
511
512      TYPE ( domain ) :: grid
513      INTEGER , INTENT(IN) :: fid
514
515      INTEGER :: ids, ide, jds, jde, kds, kde, &
516                 ims, ime, jms, jme, kms, kme, &
517                 its, ite, jts, jte, kts, kte
518
519      INTEGER :: itmp , icnt , ierr
520
521      flag_name = '                                                                                '
522
523      flag_snowh    = 0
524
525      flag_name(1:8) = 'SNOWH   '
526      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
527      IF ( ierr .EQ. 0 ) THEN
528         flag_snowh    = itmp
529      END IF
530
531      flag_snow     = 0
532
533      flag_name(1:8) = 'SNOW    '
534      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
535      IF ( ierr .EQ. 0 ) THEN
536         flag_snow     = itmp
537      END IF
538      grid%flag_snow = flag_snow
539
540   END SUBROUTINE optional_snowh
541
542!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
543
544   SUBROUTINE optional_sfc ( grid , fid , &
545                             ids, ide, jds, jde, kds, kde, &
546                             ims, ime, jms, jme, kms, kme, &
547                             its, ite, jts, jte, kts, kte  )
548
549      USE module_io_wrf
550      USE module_domain , ONLY : domain
551USE module_configure , ONLY : grid_config_rec_type
552USE module_io_domain
553
554      IMPLICIT NONE
555
556      TYPE ( domain ) :: grid
557      INTEGER , INTENT(IN) :: fid
558
559      INTEGER :: ids, ide, jds, jde, kds, kde, &
560                 ims, ime, jms, jme, kms, kme, &
561                 its, ite, jts, jte, kts, kte
562
563      INTEGER :: itmp , icnt , ierr
564
565      flag_name = '                                                                                '
566
567      flag_psfc     = 0
568      flag_soilhgt  = 0
569      flag_toposoil = 0
570      flag_slp      = 0
571
572      flag_name(1:8) = 'TOPOSOIL'
573      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
574      IF ( ierr .EQ. 0 ) THEN
575         flag_toposoil = itmp
576      END IF
577
578      flag_name(1:8) = 'PSFC    '
579      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
580      IF ( ierr .EQ. 0 ) THEN
581         flag_psfc     = itmp
582      END IF
583
584      flag_name(1:8) = 'SOILHGT '
585      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
586      IF ( ierr .EQ. 0 ) THEN
587         flag_soilhgt  = itmp
588      END IF
589
590      flag_name(1:8) = 'SLP     '
591      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
592      IF ( ierr .EQ. 0 ) THEN
593         flag_slp      = itmp
594      END IF
595   
596      grid%flag_soilhgt = flag_soilhgt
597      grid%flag_slp     = flag_slp
598      grid%flag_psfc    = flag_psfc
599   END SUBROUTINE optional_sfc
600
601!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
602
603   SUBROUTINE optional_ice ( grid , fid , &
604                             ids, ide, jds, jde, kds, kde, &
605                             ims, ime, jms, jme, kms, kme, &
606                             its, ite, jts, jte, kts, kte  )
607
608      USE module_io_wrf
609      USE module_domain , ONLY : domain
610      USE module_configure , ONLY : grid_config_rec_type
611      USE module_io_domain
612
613      IMPLICIT NONE
614
615      TYPE ( domain ) :: grid
616      INTEGER , INTENT(IN) :: fid
617
618      INTEGER :: ids, ide, jds, jde, kds, kde, &
619                 ims, ime, jms, jme, kms, kme, &
620                 its, ite, jts, jte, kts, kte
621
622      INTEGER :: itmp , icnt , ierr
623
624      flag_name = '                                                                                '
625
626      flag_icedepth = 0
627      flag_icefrac  = 0
628
629      flag_name(1:8) = 'ICEDEPTH'
630      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
631      IF ( ierr .EQ. 0 ) THEN
632         flag_icedepth = itmp
633      END IF
634
635      flag_name(1:8) = 'ICEFRAC '
636      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
637      IF ( ierr .EQ. 0 ) THEN
638         flag_icefrac  = itmp
639      END IF
640   
641   END SUBROUTINE optional_ice
642
643!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
644
645   SUBROUTINE optional_ptheta ( grid , fid , &
646                                ids, ide, jds, jde, kds, kde, &
647                                ims, ime, jms, jme, kms, kme, &
648                                its, ite, jts, jte, kts, kte  )
649
650      USE module_io_wrf
651      USE module_domain , ONLY : domain
652      USE module_configure , ONLY : grid_config_rec_type
653      USE module_io_domain
654
655      IMPLICIT NONE
656
657      TYPE ( domain ) :: grid
658      INTEGER , INTENT(IN) :: fid
659
660      INTEGER :: ids, ide, jds, jde, kds, kde, &
661                 ims, ime, jms, jme, kms, kme, &
662                 its, ite, jts, jte, kts, kte
663
664      INTEGER :: itmp , icnt , ierr
665
666      flag_name = '                                                                                '
667
668      flag_ptheta = 0
669
670      flag_name(1:8) = 'PTHETA  '
671      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
672      IF ( ierr .EQ. 0 ) THEN
673         flag_ptheta = itmp
674      END IF
675
676   END SUBROUTINE optional_ptheta
677
678!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
679
680   SUBROUTINE optional_excl_middle ( grid , fid , &
681                                     ids, ide, jds, jde, kds, kde, &
682                                     ims, ime, jms, jme, kms, kme, &
683                                     its, ite, jts, jte, kts, kte  )
684
685      USE module_io_wrf
686      USE module_domain , ONLY : domain
687      USE module_configure , ONLY : grid_config_rec_type
688      USE module_io_domain
689
690      IMPLICIT NONE
691
692      TYPE ( domain ) :: grid
693      INTEGER , INTENT(IN) :: fid
694
695      INTEGER :: ids, ide, jds, jde, kds, kde, &
696                 ims, ime, jms, jme, kms, kme, &
697                 its, ite, jts, jte, kts, kte
698
699      INTEGER :: itmp , icnt , ierr
700
701      flag_name = '                                                                                '
702
703      flag_excluded_middle = 0
704
705      flag_name(1:16) = 'EXCLUDED_MIDDLE '
706      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
707      IF ( ierr .EQ. 0 ) THEN
708         flag_excluded_middle = itmp
709      END IF
710
711   END SUBROUTINE optional_excl_middle
712
713!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
714
715   SUBROUTINE optional_lsm_levels ( grid , fid , &
716                                    ids, ide, jds, jde, kds, kde, &
717                                    ims, ime, jms, jme, kms, kme, &
718                                    its, ite, jts, jte, kts, kte  )
719
720      USE module_io_wrf
721      USE module_domain , ONLY : domain
722      !USE module_configure , ONLY : grid_config_rec_type
723      USE module_io_domain
724
725      IMPLICIT NONE
726
727      TYPE ( domain ) :: grid
728      INTEGER , INTENT(IN) :: fid
729
730      INTEGER :: ids, ide, jds, jde, kds, kde, &
731                 ims, ime, jms, jme, kms, kme, &
732                 its, ite, jts, jte, kts, kte
733
734      INTEGER :: itmp , icnt , ierr , i , j , k
735      INTEGER :: level_above
736      CHARACTER (LEN=132) :: message
737   
738      !  Initialize the soil temp and moisture flags to "field not found".
739
740      flag_name = '                                                                                '
741
742      flag_st000010 = 0
743      flag_st010040 = 0
744      flag_st040100 = 0
745      flag_st100200 = 0
746      flag_st010200 = 0
747
748      flag_sm000010 = 0
749      flag_sm010040 = 0
750      flag_sm040100 = 0
751      flag_sm100200 = 0
752      flag_sm010200 = 0
753
754      flag_sw000010 = 0
755      flag_sw010040 = 0
756      flag_sw040100 = 0
757      flag_sw100200 = 0
758      flag_sw010200 = 0
759
760      flag_st000007 = 0
761      flag_st007028 = 0
762      flag_st028100 = 0
763      flag_st100255 = 0
764
765      flag_sm000007 = 0
766      flag_sm007028 = 0
767      flag_sm028100 = 0
768      flag_sm100255 = 0
769
770      flag_soilt000 = 0
771      flag_soilt005 = 0
772      flag_soilt020 = 0
773      flag_soilt040 = 0
774      flag_soilt160 = 0
775      flag_soilt300 = 0
776
777      flag_soilm000 = 0
778      flag_soilm005 = 0
779      flag_soilm020 = 0
780      flag_soilm040 = 0
781      flag_soilm160 = 0
782      flag_soilm300 = 0
783
784      flag_soilw000 = 0
785      flag_soilw005 = 0
786      flag_soilw020 = 0
787      flag_soilw040 = 0
788      flag_soilw160 = 0
789      flag_soilw300 = 0
790
791      st_levels_input = -1
792      sm_levels_input = -1
793      sw_levels_input = -1
794
795#if (EM_CORE==1)
796!-------------------------------------------------------------------------
797! NOTE:  We are assuming that soil_layers are the same for each grid point
798!-------------------------------------------------------------------------
799      IF ( flag_soil_levels == 1 ) THEN
800
801         DO k = 1, num_st_levels_input
802            st_levels_input(k) = grid%soil_levels(its,num_st_levels_input + 1 - k,jts)
803            sm_levels_input(k) = grid%soil_levels(its,num_st_levels_input + 1 - k,jts)
804            sw_levels_input(k) = grid%soil_levels(its,num_st_levels_input + 1 - k,jts)
805         END DO
806
807         !----------------------------------------------------------------
808         ! Flip the input soil temperature/moisture/water
809         ! profiles upside down to make k=1 closest to the sfc
810         !----------------------------------------------------------------
811         DO j = jts , MIN(jde-1,jte)
812            DO k = 1, num_st_levels_input
813               DO i = its , MIN(ide-1,ite)
814                  st_input(i,k,j) = grid%soilt(i,num_st_levels_input + 1 - k,j)
815                  sm_input(i,k,j) = grid%soilm(i,num_st_levels_input + 1 - k,j)
816                  !-------------------------------------------------------------------------
817                  ! Initialize sw_input to 0. For 3D RUC soil moisture, there is no sw,
818                  ! but num_sw_levels_input is set to num_metgrid_soil_levels from the
819                  ! namelist causing sw_input to be used in init_soil_#_real subroutines
820                  !-------------------------------------------------------------------------
821                  sw_input(i,k,j) = 0.0
822               END DO
823            END DO
824         END DO
825
826      END IF    ! flag_soil_levels == 1
827
828      IF ( flag_soil_layers == 1 ) THEN
829         level_above = 0
830         DO k = 1, num_st_levels_input
831            !-------------------------------------------------------------
832            ! Calculate mid-point of each layer and set to st_levels_input
833            ! Flip the input soil depths upside down to make k=1 closest to the sfc
834            !-------------------------------------------------------------
835            st_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2
836            sm_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2
837            sw_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2
838            level_above = grid%soil_layers(its,num_st_levels_input + 1 - k,jts)
839         END DO
840
841         !----------------------------------------------------------------
842         ! Flip the input soil temperature/moisture/water
843         ! profiles upside down to make k=1 closest to the sfc
844         !----------------------------------------------------------------
845         DO j = jts , MIN(jde-1,jte)
846            DO k = 1, num_st_levels_input
847               DO i = its , MIN(ide-1,ite)
848                  st_input(i,k+1,j) = grid%st(i,num_st_levels_input + 1 - k,j)
849                  sm_input(i,k+1,j) = grid%sm(i,num_st_levels_input + 1 - k,j)
850                  sw_input(i,k+1,j) = grid%sw(i,num_st_levels_input + 1 - k,j)
851               END DO
852            END DO
853         END DO
854
855      END IF    ! flag_soil_layers == 1
856#endif
857
858      IF ( ( flag_soil_levels == 0 ) .AND. ( flag_soil_layers == 0 ) ) THEN        ! Legacy code
859
860         flag_name(1:8) = 'ST000010'
861         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
862         IF ( ierr .EQ. 0 ) THEN
863            flag_st000010 = itmp
864            num_st_levels_input = num_st_levels_input + 1
865            st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
866            DO j = jts , MIN(jde-1,jte)
867               DO i = its , MIN(ide-1,ite)
868                  st_input(i,num_st_levels_input + 1,j) = grid%st000010(i,j)
869               END DO
870            END DO
871         END IF
872         flag_name(1:8) = 'ST010040'
873         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
874         IF ( ierr .EQ. 0 ) THEN
875            flag_st010040 = itmp
876            num_st_levels_input = num_st_levels_input + 1
877            st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
878            DO j = jts , MIN(jde-1,jte)
879               DO i = its , MIN(ide-1,ite)
880                  st_input(i,num_st_levels_input + 1,j) = grid%st010040(i,j)
881               END DO
882            END DO
883         END IF
884         flag_name(1:8) = 'ST040100'
885         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
886         IF ( ierr .EQ. 0 ) THEN
887            flag_st040100 = itmp
888            num_st_levels_input = num_st_levels_input + 1
889            st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
890            DO j = jts , MIN(jde-1,jte)
891               DO i = its , MIN(ide-1,ite)
892                  st_input(i,num_st_levels_input + 1,j) = grid%st040100(i,j)
893               END DO
894            END DO
895         END IF
896         flag_name(1:8) = 'ST100200'
897         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
898         IF ( ierr .EQ. 0 ) THEN
899            flag_st100200 = itmp
900            num_st_levels_input = num_st_levels_input + 1
901            st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
902            DO j = jts , MIN(jde-1,jte)
903               DO i = its , MIN(ide-1,ite)
904                  st_input(i,num_st_levels_input + 1,j) = grid%st100200(i,j)
905               END DO
906            END DO
907         END IF
908         flag_name(1:8) = 'ST010200'
909         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
910         IF ( ierr .EQ. 0 ) THEN
911            flag_st010200 = itmp
912            num_st_levels_input = num_st_levels_input + 1
913            st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
914            DO j = jts , MIN(jde-1,jte)
915               DO i = its , MIN(ide-1,ite)
916                  st_input(i,num_st_levels_input + 1,j) = grid%st010200(i,j)
917               END DO
918            END DO
919         END IF
920         flag_name(1:8) = 'ST000007'
921         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
922         IF ( ierr .EQ. 0 ) THEN
923            flag_st000007 = itmp
924            num_st_levels_input = num_st_levels_input + 1
925            st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
926            DO j = jts , MIN(jde-1,jte)
927               DO i = its , MIN(ide-1,ite)
928                  st_input(i,num_st_levels_input + 1,j) = grid%st000007(i,j)
929               END DO
930            END DO
931         END IF
932         flag_name(1:8) = 'ST007028'
933         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
934         IF ( ierr .EQ. 0 ) THEN
935            flag_st007028 = itmp
936            num_st_levels_input = num_st_levels_input + 1
937            st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
938            DO j = jts , MIN(jde-1,jte)
939               DO i = its , MIN(ide-1,ite)
940                  st_input(i,num_st_levels_input + 1,j) = grid%st007028(i,j)
941               END DO
942            END DO
943         END IF
944         flag_name(1:8) = 'ST028100'
945         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
946         IF ( ierr .EQ. 0 ) THEN
947            flag_st028100 = itmp
948            num_st_levels_input = num_st_levels_input + 1
949            st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
950            DO j = jts , MIN(jde-1,jte)
951               DO i = its , MIN(ide-1,ite)
952                  st_input(i,num_st_levels_input + 1,j) = grid%st028100(i,j)
953               END DO
954            END DO
955         END IF
956         flag_name(1:8) = 'ST100255'
957         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
958         IF ( ierr .EQ. 0 ) THEN
959            flag_st100255 = itmp
960            num_st_levels_input = num_st_levels_input + 1
961            st_levels_input(num_st_levels_input) = char2int2(flag_name(3:8))
962            DO j = jts , MIN(jde-1,jte)
963               DO i = its , MIN(ide-1,ite)
964                  st_input(i,num_st_levels_input + 1,j) = grid%st100255(i,j)
965               END DO
966            END DO
967         END IF
968         flag_name(1:8) = 'SOILT000'
969         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
970         IF ( ierr .EQ. 0 ) THEN
971            flag_soilt000 = itmp
972            num_st_levels_input = num_st_levels_input + 1
973            st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
974            DO j = jts , MIN(jde-1,jte)
975               DO i = its , MIN(ide-1,ite)
976                  st_input(i,num_st_levels_input ,j) = grid%soilt000(i,j)
977               END DO
978            END DO
979         END IF
980         flag_name(1:8) = 'SOILT005'
981         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
982         IF ( ierr .EQ. 0 ) THEN
983            flag_soilt005 = itmp
984            num_st_levels_input = num_st_levels_input + 1
985            st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
986            DO j = jts , MIN(jde-1,jte)
987               DO i = its , MIN(ide-1,ite)
988                  st_input(i,num_st_levels_input ,j) = grid%soilt005(i,j)
989               END DO
990            END DO
991         END IF
992         flag_name(1:8) = 'SOILT020'
993         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
994         IF ( ierr .EQ. 0 ) THEN
995            flag_soilt020 = itmp
996            num_st_levels_input = num_st_levels_input + 1
997            st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
998            DO j = jts , MIN(jde-1,jte)
999               DO i = its , MIN(ide-1,ite)
1000                  st_input(i,num_st_levels_input ,j) = grid%soilt020(i,j)
1001               END DO
1002            END DO
1003         END IF
1004         flag_name(1:8) = 'SOILT040'
1005         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1006         IF ( ierr .EQ. 0 ) THEN
1007            flag_soilt040 = itmp
1008            num_st_levels_input = num_st_levels_input + 1
1009            st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
1010            DO j = jts , MIN(jde-1,jte)
1011               DO i = its , MIN(ide-1,ite)
1012                  st_input(i,num_st_levels_input ,j) = grid%soilt040(i,j)
1013               END DO
1014            END DO
1015         END IF
1016         flag_name(1:8) = 'SOILT160'
1017         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1018         IF ( ierr .EQ. 0 ) THEN
1019            flag_soilt160 = itmp
1020            num_st_levels_input = num_st_levels_input + 1
1021            st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
1022            DO j = jts , MIN(jde-1,jte)
1023               DO i = its , MIN(ide-1,ite)
1024                  st_input(i,num_st_levels_input ,j) = grid%soilt160(i,j)
1025               END DO
1026            END DO
1027         END IF
1028         flag_name(1:8) = 'SOILT300'
1029         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1030         IF ( ierr .EQ. 0 ) THEN
1031            flag_soilt300 = itmp
1032            num_st_levels_input = num_st_levels_input + 1
1033            st_levels_input(num_st_levels_input) = char2int1(flag_name(6:8))
1034            DO j = jts , MIN(jde-1,jte)
1035               DO i = its , MIN(ide-1,ite)
1036                  st_input(i,num_st_levels_input ,j) = grid%soilt300(i,j)
1037               END DO
1038            END DO
1039         END IF
1040
1041         flag_name(1:8) = 'SM000010'
1042         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1043         IF ( ierr .EQ. 0 ) THEN
1044            flag_sm000010 = itmp
1045            num_sm_levels_input = num_sm_levels_input + 1
1046            sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
1047            DO j = jts , MIN(jde-1,jte)
1048               DO i = its , MIN(ide-1,ite)
1049                  sm_input(i,num_sm_levels_input + 1,j) = grid%sm000010(i,j)
1050               END DO
1051            END DO
1052         END IF
1053         flag_name(1:8) = 'SM010040'
1054         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1055         IF ( ierr .EQ. 0 ) THEN
1056            flag_sm010040 = itmp
1057            num_sm_levels_input = num_sm_levels_input + 1
1058            sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
1059            DO j = jts , MIN(jde-1,jte)
1060               DO i = its , MIN(ide-1,ite)
1061                  sm_input(i,num_sm_levels_input + 1,j) = grid%sm010040(i,j)
1062               END DO
1063            END DO
1064         END IF
1065         flag_name(1:8) = 'SM040100'
1066         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1067         IF ( ierr .EQ. 0 ) THEN
1068            flag_sm040100 = itmp
1069            num_sm_levels_input = num_sm_levels_input + 1
1070            sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
1071            DO j = jts , MIN(jde-1,jte)
1072               DO i = its , MIN(ide-1,ite)
1073                  sm_input(i,num_sm_levels_input + 1,j) = grid%sm040100(i,j)
1074               END DO
1075            END DO
1076         END IF
1077         flag_name(1:8) = 'SM100200'
1078         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1079         IF ( ierr .EQ. 0 ) THEN
1080            flag_sm100200 = itmp
1081            num_sm_levels_input = num_sm_levels_input + 1
1082            sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
1083            DO j = jts , MIN(jde-1,jte)
1084               DO i = its , MIN(ide-1,ite)
1085                  sm_input(i,num_sm_levels_input + 1,j) = grid%sm100200(i,j)
1086               END DO
1087            END DO
1088         END IF
1089         flag_name(1:8) = 'SM010200'
1090         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1091         IF ( ierr .EQ. 0 ) THEN
1092            flag_sm010200 = itmp
1093            num_sm_levels_input = num_sm_levels_input + 1
1094            sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
1095            DO j = jts , MIN(jde-1,jte)
1096               DO i = its , MIN(ide-1,ite)
1097                  sm_input(i,num_sm_levels_input + 1,j) = grid%sm010200(i,j)
1098               END DO
1099            END DO
1100         END IF
1101         flag_name(1:8) = 'SM000007'
1102         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1103         IF ( ierr .EQ. 0 ) THEN
1104            flag_sm000007 = itmp
1105            num_sm_levels_input = num_sm_levels_input + 1
1106            sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
1107            DO j = jts , MIN(jde-1,jte)
1108               DO i = its , MIN(ide-1,ite)
1109                  sm_input(i,num_sm_levels_input + 1,j) = grid%sm000007(i,j)
1110               END DO
1111            END DO
1112         END IF
1113         flag_name(1:8) = 'SM007028'
1114         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1115         IF ( ierr .EQ. 0 ) THEN
1116            flag_sm007028 = itmp
1117            num_sm_levels_input = num_sm_levels_input + 1
1118            sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
1119            DO j = jts , MIN(jde-1,jte)
1120               DO i = its , MIN(ide-1,ite)
1121                  sm_input(i,num_sm_levels_input + 1,j) = grid%sm007028(i,j)
1122               END DO
1123            END DO
1124         END IF
1125         flag_name(1:8) = 'SM028100'
1126         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1127         IF ( ierr .EQ. 0 ) THEN
1128            flag_sm028100 = itmp
1129            num_sm_levels_input = num_sm_levels_input + 1
1130            sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
1131            DO j = jts , MIN(jde-1,jte)
1132               DO i = its , MIN(ide-1,ite)
1133                  sm_input(i,num_sm_levels_input + 1,j) = grid%sm028100(i,j)
1134               END DO
1135            END DO
1136         END IF
1137         flag_name(1:8) = 'SM100255'
1138         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1139         IF ( ierr .EQ. 0 ) THEN
1140            flag_sm100255 = itmp
1141            num_sm_levels_input = num_sm_levels_input + 1
1142            sm_levels_input(num_sm_levels_input) = char2int2(flag_name(3:8))
1143            DO j = jts , MIN(jde-1,jte)
1144               DO i = its , MIN(ide-1,ite)
1145                  sm_input(i,num_sm_levels_input + 1,j) = grid%sm100255(i,j)
1146               END DO
1147            END DO
1148         END IF
1149         flag_name(1:8) = 'SOILM000'
1150         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1151         IF ( ierr .EQ. 0 ) THEN
1152            flag_soilm000 = itmp
1153            num_sm_levels_input = num_sm_levels_input + 1
1154            sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
1155            DO j = jts , MIN(jde-1,jte)
1156               DO i = its , MIN(ide-1,ite)
1157                  sm_input(i,num_sm_levels_input ,j) = grid%soilm000(i,j)
1158               END DO
1159            END DO
1160         END IF
1161         flag_name(1:8) = 'SOILM005'
1162         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1163         IF ( ierr .EQ. 0 ) THEN
1164            flag_soilm005 = itmp
1165            num_sm_levels_input = num_sm_levels_input + 1
1166            sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
1167            DO j = jts , MIN(jde-1,jte)
1168               DO i = its , MIN(ide-1,ite)
1169                  sm_input(i,num_sm_levels_input ,j) = grid%soilm005(i,j)
1170               END DO
1171            END DO
1172         END IF
1173         flag_name(1:8) = 'SOILM020'
1174         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1175         IF ( ierr .EQ. 0 ) THEN
1176            flag_soilm020 = itmp
1177            num_sm_levels_input = num_sm_levels_input + 1
1178            sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
1179            DO j = jts , MIN(jde-1,jte)
1180               DO i = its , MIN(ide-1,ite)
1181                  sm_input(i,num_sm_levels_input ,j) = grid%soilm020(i,j)
1182               END DO
1183            END DO
1184         END IF
1185         flag_name(1:8) = 'SOILM040'
1186         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1187         IF ( ierr .EQ. 0 ) THEN
1188            flag_soilm040 = itmp
1189            num_sm_levels_input = num_sm_levels_input + 1
1190            sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
1191            DO j = jts , MIN(jde-1,jte)
1192               DO i = its , MIN(ide-1,ite)
1193                  sm_input(i,num_sm_levels_input ,j) = grid%soilm040(i,j)
1194               END DO
1195            END DO
1196         END IF
1197         flag_name(1:8) = 'SOILM160'
1198         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1199         IF ( ierr .EQ. 0 ) THEN
1200            flag_soilm160 = itmp
1201            num_sm_levels_input = num_sm_levels_input + 1
1202            sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
1203            DO j = jts , MIN(jde-1,jte)
1204               DO i = its , MIN(ide-1,ite)
1205                  sm_input(i,num_sm_levels_input ,j) = grid%soilm160(i,j)
1206               END DO
1207            END DO
1208         END IF
1209         flag_name(1:8) = 'SOILM300'
1210         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1211         IF ( ierr .EQ. 0 ) THEN
1212            flag_soilm300 = itmp
1213            num_sm_levels_input = num_sm_levels_input + 1
1214            sm_levels_input(num_sm_levels_input) = char2int1(flag_name(6:8))
1215            DO j = jts , MIN(jde-1,jte)
1216               DO i = its , MIN(ide-1,ite)
1217                  sm_input(i,num_sm_levels_input ,j) = grid%soilm300(i,j)
1218               END DO
1219            END DO
1220         END IF
1221
1222         flag_name(1:8) = 'SW000010'
1223         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1224         IF ( ierr .EQ. 0 ) THEN
1225            flag_sw000010 = itmp
1226            num_sw_levels_input = num_sw_levels_input + 1
1227            sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
1228            DO j = jts , MIN(jde-1,jte)
1229               DO i = its , MIN(ide-1,ite)
1230                  sw_input(i,num_sw_levels_input + 1,j) = grid%sw000010(i,j)
1231               END DO
1232            END DO
1233         END IF
1234         flag_name(1:8) = 'SW010040'
1235         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1236         IF ( ierr .EQ. 0 ) THEN
1237            flag_sw010040 = itmp
1238            num_sw_levels_input = num_sw_levels_input + 1
1239            sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
1240            DO j = jts , MIN(jde-1,jte)
1241               DO i = its , MIN(ide-1,ite)
1242                  sw_input(i,num_sw_levels_input + 1,j) = grid%sw010040(i,j)
1243               END DO
1244            END DO
1245         END IF
1246         flag_name(1:8) = 'SW040100'
1247         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1248         IF ( ierr .EQ. 0 ) THEN
1249            flag_sw040100 = itmp
1250            num_sw_levels_input = num_sw_levels_input + 1
1251            sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
1252            DO j = jts , MIN(jde-1,jte)
1253               DO i = its , MIN(ide-1,ite)
1254                  sw_input(i,num_sw_levels_input + 1,j) = grid%sw040100(i,j)
1255               END DO
1256            END DO
1257         END IF
1258         flag_name(1:8) = 'SW100200'
1259         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1260         IF ( ierr .EQ. 0 ) THEN
1261            flag_sw100200 = itmp
1262            num_sw_levels_input = num_sw_levels_input + 1
1263            sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
1264            DO j = jts , MIN(jde-1,jte)
1265               DO i = its , MIN(ide-1,ite)
1266                  sw_input(i,num_sw_levels_input + 1,j) = grid%sw100200(i,j)
1267               END DO
1268            END DO
1269         END IF
1270         flag_name(1:8) = 'SW010200'
1271         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1272         IF ( ierr .EQ. 0 ) THEN
1273            flag_sw010200 = itmp
1274            num_sw_levels_input = num_sw_levels_input + 1
1275            sw_levels_input(num_sw_levels_input) = char2int2(flag_name(3:8))
1276            DO j = jts , MIN(jde-1,jte)
1277               DO i = its , MIN(ide-1,ite)
1278                  sw_input(i,num_sw_levels_input + 1,j) = grid%sw010200(i,j)
1279               END DO
1280            END DO
1281         END IF
1282         flag_name(1:8) = 'SOILW000'
1283         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1284         IF ( ierr .EQ. 0 ) THEN
1285            flag_soilw000 = itmp
1286            num_sw_levels_input = num_sw_levels_input + 1
1287            sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
1288            DO j = jts , MIN(jde-1,jte)
1289               DO i = its , MIN(ide-1,ite)
1290                  sw_input(i,num_sw_levels_input ,j) = grid%soilw000(i,j)
1291               END DO
1292            END DO
1293         END IF
1294         flag_name(1:8) = 'SOILW005'
1295         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1296         IF ( ierr .EQ. 0 ) THEN
1297            flag_soilw005 = itmp
1298            num_sw_levels_input = num_sw_levels_input + 1
1299            sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
1300            DO j = jts , MIN(jde-1,jte)
1301               DO i = its , MIN(ide-1,ite)
1302                  sw_input(i,num_sw_levels_input ,j) = grid%soilw005(i,j)
1303               END DO
1304            END DO
1305         END IF
1306         flag_name(1:8) = 'SOILW020'
1307         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1308         IF ( ierr .EQ. 0 ) THEN
1309            flag_soilw020 = itmp
1310            num_sw_levels_input = num_sw_levels_input + 1
1311            sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
1312            DO j = jts , MIN(jde-1,jte)
1313               DO i = its , MIN(ide-1,ite)
1314                  sw_input(i,num_sw_levels_input ,j) = grid%soilw020(i,j)
1315               END DO
1316            END DO
1317         END IF
1318         flag_name(1:8) = 'SOILW040'
1319         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1320         IF ( ierr .EQ. 0 ) THEN
1321            flag_soilw040 = itmp
1322            num_sw_levels_input = num_sw_levels_input + 1
1323            sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
1324            DO j = jts , MIN(jde-1,jte)
1325               DO i = its , MIN(ide-1,ite)
1326                  sw_input(i,num_sw_levels_input ,j) = grid%soilw040(i,j)
1327               END DO
1328            END DO
1329         END IF
1330         flag_name(1:8) = 'SOILW160'
1331         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1332         IF ( ierr .EQ. 0 ) THEN
1333            flag_soilw160 = itmp
1334            num_sw_levels_input = num_sw_levels_input + 1
1335            sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
1336            DO j = jts , MIN(jde-1,jte)
1337               DO i = its , MIN(ide-1,ite)
1338                  sw_input(i,num_sw_levels_input ,j) = grid%soilw160(i,j)
1339               END DO
1340            END DO
1341         END IF
1342         flag_name(1:8) = 'SOILW300'
1343         CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
1344         IF ( ierr .EQ. 0 ) THEN
1345            flag_soilw300 = itmp
1346            num_sw_levels_input = num_sw_levels_input + 1
1347            sw_levels_input(num_sw_levels_input) = char2int1(flag_name(6:8))
1348            DO j = jts , MIN(jde-1,jte)
1349               DO i = its , MIN(ide-1,ite)
1350                  sw_input(i,num_sw_levels_input ,j) = grid%soilw300(i,j)
1351               END DO
1352            END DO
1353         END IF
1354
1355      END IF       ! End of legacy code for temperature and moisture
1356
1357! The flags flag_st*, flag_sm*, flag_sw*, flag_soilt*, flag_soilm*, flag_soilw* are no longer used.
1358! If the new flags flag_soil_layers or flag_soil_levels are not set in met_em, and some legacy
1359! flags are, reset the new flags
1360   
1361      IF ( ( flag_soil_levels == 0 ) .AND. ( flag_soil_layers == 0 ) ) THEN
1362         IF ( flag_st000010 == 1 .OR. flag_st010040 == 1 .OR. flag_st040100 == 1 .OR. &
1363              flag_st100200 == 1 .OR. flag_st010200 == 1 .OR. &
1364              flag_sm000010 == 1 .OR. flag_sm010040 == 1 .OR. flag_sm040100 == 1 .OR. &
1365              flag_sm100200 == 1 .OR. flag_sm010200 == 1 .OR. &
1366              flag_sw000010 == 1 .OR. flag_sw010040 == 1 .OR. flag_sw040100 == 1 .OR. &
1367              flag_sw100200 == 1 .OR. flag_sw010200 == 1 .OR. &
1368              flag_st000007 == 1 .OR. flag_st007028 == 1 .OR. flag_st028100 == 1 .OR. &
1369              flag_st100255 == 1 .OR. &
1370              flag_sm000007 == 1 .OR. flag_sm007028 == 1 .OR. flag_sm028100 == 1 .OR. &
1371              flag_sm100255 == 1 ) THEN
1372            flag_soil_layers=1
1373         END IF
1374         IF ( flag_soilt000 == 1 .OR. flag_soilt005 == 1 .OR. flag_soilt020 == 1 .OR. &
1375              flag_soilt040 == 1 .OR. flag_soilt160 == 1 .OR. flag_soilt300 == 1 .OR. &
1376              flag_soilm000 == 1 .OR. flag_soilm005 == 1 .OR. flag_soilm020 == 1 .OR. &
1377              flag_soilm040 == 1 .OR. flag_soilm160 == 1 .OR. flag_soilm300 == 1 .OR. &
1378              flag_soilw000 == 1 .OR. flag_soilw005 == 1 .OR. flag_soilw020 == 1 .OR. &
1379              flag_soilw040 == 1 .OR. flag_soilw160 == 1 .OR. flag_soilw300 == 1 ) THEN
1380            flag_soil_levels=1
1381         END IF
1382      END IF
1383
1384      write (message,'(A,I3)') 'flag_soil_layers at end of optional_lsm_levels is',flag_soil_layers
1385      CALL wrf_debug(1,message)
1386      write (message,'(A,I3)') 'flag_soil_levels at end of optional_lsm_levels is',flag_soil_levels
1387      CALL wrf_debug(1,message)
1388
1389      write (message,'(A,10(i3,1x))') 'st_levels_input = ', (st_levels_input(k), k=1,num_st_levels_input)
1390      CALL wrf_debug(1,message)
1391      write (message,'(A,10(i3,1x))') 'sm_levels_input = ', (sm_levels_input(k), k=1,num_sm_levels_input)
1392      CALL wrf_debug(1,message)
1393      write (message,'(A,10(i3,1x))') 'sw_levels_input = ', (sw_levels_input(k), k=1,num_sw_levels_input)
1394      CALL wrf_debug(1,message)
1395
1396      !  OK, let's do a quick sanity check.
1397 
1398      IF ( ( num_st_levels_input .GT. num_st_levels_alloc ) .OR. &
1399           ( num_sm_levels_input .GT. num_sm_levels_alloc ) .OR. &
1400           ( num_sw_levels_input .GT. num_sw_levels_alloc ) ) THEN
1401         print *,'pain and woe, the soil level allocation is too small'
1402         CALL wrf_error_fatal ( 'soil_levels_too_few' )
1403      END IF
1404
1405   END SUBROUTINE optional_lsm_levels
1406
1407!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1408
1409   FUNCTION char2int1( string3 ) RESULT ( int1 )
1410      CHARACTER (LEN=3) , INTENT(IN) :: string3
1411      INTEGER :: i1 , int1
1412      READ(string3,fmt='(I3)') i1
1413      int1 = i1
1414   END FUNCTION char2int1
1415
1416!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1417
1418   FUNCTION char2int2( string6 ) RESULT ( int1 )
1419      CHARACTER (LEN=6) , INTENT(IN) :: string6
1420      INTEGER :: i2 , i1 , int1
1421      READ(string6,fmt='(I3,I3)') i1,i2
1422      int1 = ( i2 + i1 ) / 2
1423   END FUNCTION char2int2
1424
1425!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1426#endif
1427END MODULE module_optional_input
Note: See TracBrowser for help on using the repository browser.