Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

module_optional_input.F @ 1939

Last change on this file since 1939 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
1	MODULE 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
40	CONTAINS
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
266	USE module_configure , ONLY : grid_config_rec_type
267	USE 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
349	USE module_configure , ONLY : grid_config_rec_type
350	USE 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
402	USE module_configure , ONLY : grid_config_rec_type
403	USE 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
437	USE module_configure , ONLY : grid_config_rec_type
438	USE 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
472	USE module_configure , ONLY : grid_config_rec_type
473	USE 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
507	USE module_configure , ONLY : grid_config_rec_type
508	USE 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
551	USE module_configure , ONLY : grid_config_rec_type
552	USE 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
1427	END MODULE module_optional_input

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

Download in other formats:

Original Format