Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

ndown_em.F @ 2759

Last change on this file since 2759 was 2759, checked in by aslmd, 2 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 74.0 KB

Line
1	!WRF:DRIVER_LAYER:MAIN
2	!
3
4	PROGRAM ndown_em
5
6	USE module_machine
7	USE module_domain, ONLY : domain
8	USE module_initialize_real, ONLY : wrfu_initialize, rebalance_driver
9	USE module_integrate
10	USE module_driver_constants
11	USE module_configure, ONLY : grid_config_rec_type, model_config_rec
12	USE module_io_domain
13	USE module_utility
14
15	USE module_timing
16	USE module_wrf_error
17	#ifdef DM_PARALLEL
18	USE module_dm
19	#endif
20
21	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
22	!new for bc
23	USE module_bc
24	USE module_big_step_utilities_em
25	USE module_get_file_names
26	#ifdef WRF_CHEM
27	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
28	! for chemistry
29	USE module_input_chem_data
30	! USE module_input_chem_bioemiss
31	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
32	#endif
33
34	IMPLICIT NONE
35	! interface
36	INTERFACE
37	! mediation-supplied
38	SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags)
39	USE module_domain
40	TYPE (domain) grid
41	TYPE (grid_config_rec_type) config_flags
42	END SUBROUTINE med_read_wrf_chem_bioemiss
43
44	SUBROUTINE init_domain_constants_em_ptr ( parent , nest )
45	USE module_domain
46	USE module_configure
47	TYPE(domain), POINTER :: parent , nest
48	END SUBROUTINE init_domain_constants_em_ptr
49
50	END INTERFACE
51
52
53
54	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
55	!new for bc
56	INTEGER :: ids , ide , jds , jde , kds , kde
57	INTEGER :: ims , ime , jms , jme , kms , kme
58	INTEGER :: ips , ipe , jps , jpe , kps , kpe
59	INTEGER :: its , ite , jts , jte , kts , kte
60	INTEGER :: nids, nide, njds, njde, nkds, nkde, &
61	nims, nime, njms, njme, nkms, nkme, &
62	nips, nipe, njps, njpe, nkps, nkpe
63	INTEGER :: spec_bdy_width
64	INTEGER :: i , j , k , nvchem
65	INTEGER :: time_loop_max , time_loop
66	INTEGER :: total_time_sec , file_counter
67	INTEGER :: julyr , julday , iswater , map_proj
68	INTEGER :: icnt
69
70	REAL :: dt , new_bdy_frq
71	REAL :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon
72
73	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1
74	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1
75	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2
76	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2
77	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: cbdy3dtemp1 , cbdy3dtemp2
78	REAL , DIMENSION(:,:,:,:) , ALLOCATABLE :: cbdy3dtemp0
79
80	CHARACTER(LEN=19) :: start_date_char , current_date_char , end_date_char
81	CHARACTER(LEN=19) :: stopTimeStr
82
83	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
84
85	INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
86
87	REAL :: time
88	INTEGER :: rc
89
90	INTEGER :: loop , levels_to_process
91	INTEGER , PARAMETER :: max_sanity_file_loop = 100
92
93	TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain, parent_grid , nested_grid
94	TYPE (domain) :: dummy
95	TYPE (grid_config_rec_type) :: config_flags
96	INTEGER :: number_at_same_level
97	INTEGER :: time_step_begin_restart
98
99	INTEGER :: max_dom , domain_id , fid , fido, fidb , oid , idum1 , idum2 , ierr
100	INTEGER :: status_next_var
101	INTEGER :: debug_level
102	LOGICAL :: input_from_file , need_new_file
103	CHARACTER (LEN=19) :: date_string
104
105	#ifdef DM_PARALLEL
106	INTEGER :: nbytes
107	INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN
108	INTEGER :: configbuf( configbuflen )
109	LOGICAL , EXTERNAL :: wrf_dm_on_monitor
110	#endif
111
112	INTEGER :: idsi
113	CHARACTER (LEN=80) :: inpname , outname , bdyname
114	CHARACTER (LEN=80) :: si_inpname
115	character *19 :: temp19
116	character *24 :: temp24 , temp24b
117	character(len=24) :: start_date_hold
118
119	CHARACTER (LEN=80) :: message
120	integer :: ii
121
122	#include "version_decl"
123
124	! Interface block for routine that passes pointers and needs to know that they
125	! are receiving pointers.
126
127	INTERFACE
128
129	SUBROUTINE med_interp_domain ( parent_grid , nested_grid )
130	USE module_domain
131	USE module_configure
132	TYPE(domain), POINTER :: parent_grid , nested_grid
133	END SUBROUTINE med_interp_domain
134
135	SUBROUTINE Setup_Timekeeping( parent_grid )
136	USE module_domain
137	TYPE(domain), POINTER :: parent_grid
138	END SUBROUTINE Setup_Timekeeping
139
140	END INTERFACE
141
142	! Define the name of this program (program_name defined in module_domain)
143
144	program_name = "NDOWN_EM " // TRIM(release_version) // " PREPROCESSOR"
145
146	#ifdef DM_PARALLEL
147	CALL disable_quilting
148	#endif
149
150	! Initialize the modules used by the WRF system. Many of the CALLs made from the
151	! init_modules routine are NO-OPs. Typical initializations are: the size of a
152	! REAL, setting the file handles to a pre-use value, defining moisture and
153	! chemistry indices, etc.
154
155	CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called)
156	CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
157	CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called)
158
159	! Get the NAMELIST data. This is handled in the initial_config routine. All of the
160	! NAMELIST input variables are assigned to the model_config_rec structure. Below,
161	! note for parallel processing, only the monitor processor handles the raw Fortran
162	! I/O, and then broadcasts the info to each of the other nodes.
163
164	#ifdef DM_PARALLEL
165	IF ( wrf_dm_on_monitor() ) THEN
166	CALL initial_config
167	ENDIF
168	CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
169	CALL wrf_dm_bcast_bytes( configbuf, nbytes )
170	CALL set_config_as_buffer( configbuf, configbuflen )
171	CALL wrf_dm_initialize
172	#else
173	CALL initial_config
174	#endif
175
176	! And here is an instance of using the information in the NAMELIST.
177
178	CALL nl_get_debug_level ( 1, debug_level )
179	CALL set_wrf_debug_level ( debug_level )
180
181	! Allocated and configure the mother domain. Since we are in the nesting down
182	! mode, we know a) we got a nest, and b) we only got 1 nest.
183
184	NULLIFY( null_domain )
185
186	CALL wrf_message ( program_name )
187	CALL wrf_debug ( 100 , 'ndown_em: calling alloc_and_configure_domain coarse ' )
188	CALL alloc_and_configure_domain ( domain_id = 1 , &
189	grid = head_grid , &
190	parent = null_domain , &
191	kid = -1 )
192
193	parent_grid => head_grid
194
195	! Set up time initializations.
196
197	CALL Setup_Timekeeping ( parent_grid )
198
199	CALL domain_clock_set( head_grid, &
200	time_step_seconds=model_config_rec%interval_seconds )
201	CALL wrf_debug ( 100 , 'ndown_em: calling model_to_grid_config_rec ' )
202	CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
203	CALL wrf_debug ( 100 , 'ndown_em: calling set_scalar_indices_from_config ' )
204	CALL set_scalar_indices_from_config ( parent_grid%id , idum1, idum2 )
205
206	! Initialize the I/O for WRF.
207
208	CALL wrf_debug ( 100 , 'ndown_em: calling init_wrfio' )
209	CALL init_wrfio
210
211	! Some of the configuration values may have been modified from the initial READ
212	! of the NAMELIST, so we re-broadcast the configuration records.
213
214	#ifdef DM_PARALLEL
215	CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
216	CALL wrf_dm_bcast_bytes( configbuf, nbytes )
217	CALL set_config_as_buffer( configbuf, configbuflen )
218	#endif
219
220	! We need to current and starting dates for the output files. The times need to be incremented
221	! so that the lateral BC files are not overwritten.
222
223	#ifdef PLANET
224	WRITE ( start_date_char , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
225	model_config_rec%start_year (parent_grid%id) , &
226	model_config_rec%start_day (parent_grid%id) , &
227	model_config_rec%start_hour (parent_grid%id) , &
228	model_config_rec%start_minute(parent_grid%id) , &
229	model_config_rec%start_second(parent_grid%id)
230
231	WRITE ( end_date_char , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
232	model_config_rec% end_year (parent_grid%id) , &
233	model_config_rec% end_day (parent_grid%id) , &
234	model_config_rec% end_hour (parent_grid%id) , &
235	model_config_rec% end_minute(parent_grid%id) , &
236	model_config_rec% end_second(parent_grid%id)
237	#else
238	WRITE ( start_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
239	model_config_rec%start_year (parent_grid%id) , &
240	model_config_rec%start_month (parent_grid%id) , &
241	model_config_rec%start_day (parent_grid%id) , &
242	model_config_rec%start_hour (parent_grid%id) , &
243	model_config_rec%start_minute(parent_grid%id) , &
244	model_config_rec%start_second(parent_grid%id)
245
246	WRITE ( end_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
247	model_config_rec% end_year (parent_grid%id) , &
248	model_config_rec% end_month (parent_grid%id) , &
249	model_config_rec% end_day (parent_grid%id) , &
250	model_config_rec% end_hour (parent_grid%id) , &
251	model_config_rec% end_minute(parent_grid%id) , &
252	model_config_rec% end_second(parent_grid%id)
253	#endif
254
255	! Override stop time with value computed above.
256	CALL domain_clock_set( parent_grid, stop_timestr=end_date_char )
257
258	CALL geth_idts ( end_date_char , start_date_char , total_time_sec )
259
260	new_bdy_frq = model_config_rec%interval_seconds
261	time_loop_max = total_time_sec / model_config_rec%interval_seconds + 1
262
263	start_date = start_date_char // '.0000'
264	current_date = start_date_char // '.0000'
265	start_date_hold = start_date_char // '.0000'
266	current_date_char = start_date_char
267
268	! Get a list of available file names to try. This fills up the eligible_file_name
269	! array with number_of_eligible_files entries. This routine issues a nonstandard
270	! call (system).
271
272	file_counter = 1
273	need_new_file = .FALSE.
274	CALL unix_ls ( 'wrfout' , parent_grid%id )
275
276	! Open the input data (wrfout_d01_xxxxxx) for reading.
277
278	CALL wrf_debug ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) )
279	CALL open_r_dataset ( fid, TRIM(eligible_file_name(file_counter)) , head_grid , config_flags , "DATASET=AUXINPUT1", ierr )
280	IF ( ierr .NE. 0 ) THEN
281	WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(eligible_file_name(file_counter)), &
282	' for reading ierr=',ierr
283	CALL WRF_ERROR_FATAL ( wrf_err_message )
284	ENDIF
285
286	! We know how many time periods to process, so we begin.
287
288	big_time_loop_thingy : DO time_loop = 1 , time_loop_max
289
290	! Which date are we currently soliciting?
291
292	CALL geth_newdate ( date_string , start_date_char , ( time_loop - 1 ) * NINT ( new_bdy_frq) )
293	print *,'-------->>> Processing data: loop=',time_loop,' date/time = ',date_string
294	current_date_char = date_string
295	current_date = date_string // '.0000'
296	start_date = date_string // '.0000'
297	print *,'loopmax = ', time_loop_max, ' ending date = ',end_date_char
298	CALL domain_clock_set( parent_grid, &
299	current_timestr=current_date(1:19) )
300
301	! Which times are in this file, and more importantly, are any of them the
302	! ones that we want? We need to loop over times in each files, loop
303	! over files.
304
305	get_the_right_time : DO
306
307	CALL wrf_get_next_time ( fid , date_string , status_next_var )
308	print *,'file date/time = ',date_string,' desired date = ',current_date_char,' status = ', status_next_var
309
310	IF ( status_next_var .NE. 0 ) THEN
311	CALL wrf_debug ( 100 , 'ndown_em main: calling close_dataset for ' // TRIM(eligible_file_name(file_counter)) )
312	CALL close_dataset ( fid , config_flags , "DATASET=INPUT" )
313	file_counter = file_counter + 1
314	IF ( file_counter .GT. number_of_eligible_files ) THEN
315	WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: opening too many files'
316	CALL WRF_ERROR_FATAL ( wrf_err_message )
317	END IF
318	CALL wrf_debug ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) )
319	CALL open_r_dataset ( fid, TRIM(eligible_file_name(file_counter)) , head_grid , config_flags , "DATASET=INPUT", ierr )
320	IF ( ierr .NE. 0 ) THEN
321	WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(eligible_file_name(file_counter)), &
322	' for reading ierr=',ierr
323	CALL WRF_ERROR_FATAL ( wrf_err_message )
324	ENDIF
325	CYCLE get_the_right_time
326	ELSE IF ( TRIM(date_string) .LT. TRIM(current_date_char) ) THEN
327	CYCLE get_the_right_time
328	ELSE IF ( TRIM(date_string) .EQ. TRIM(current_date_char) ) THEN
329	EXIT get_the_right_time
330	ELSE IF ( TRIM(date_string) .GT. TRIM(current_date_char) ) THEN
331	WRITE( wrf_err_message , FMT='(A,A,A,A,A)' ) 'Found ',TRIM(date_string),' before I found ',TRIM(current_date_char),'.'
332	CALL WRF_ERROR_FATAL ( wrf_err_message )
333	END IF
334	END DO get_the_right_time
335
336	CALL wrf_debug ( 100 , 'wrf: calling input_history' )
337	CALL wrf_get_previous_time ( fid , date_string , status_next_var )
338	CALL input_history ( fid , head_grid , config_flags, ierr )
339	CALL wrf_debug ( 100 , 'wrf: back from input_history' )
340
341	! Get the coarse grid info for later transfer to the fine grid domain.
342
343	CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , map_proj , 1 , icnt , ierr )
344	CALL wrf_get_dom_ti_real ( fid , 'DX' , dx , 1 , icnt , ierr )
345	CALL wrf_get_dom_ti_real ( fid , 'DY' , dy , 1 , icnt , ierr )
346	CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , cen_lat , 1 , icnt , ierr )
347	CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , cen_lon , 1 , icnt , ierr )
348	CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , truelat1 , 1 , icnt , ierr )
349	CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , truelat2 , 1 , icnt , ierr )
350	CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , icnt , ierr )
351	CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , stand_lon , 1 , icnt , ierr )
352	! CALL wrf_get_dom_ti_real ( fid , 'GMT' , gmt , 1 , icnt , ierr )
353	! CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , icnt , ierr )
354	! CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , icnt , ierr )
355	CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , icnt , ierr )
356
357	! First time in, do this: allocate sapce for the fine grid, get the config flags, open the
358	! wrfinput and wrfbdy files. This COULD be done outside the time loop, I think, so check it
359	! out and move it up if you can.
360
361	IF ( time_loop .EQ. 1 ) THEN
362
363	CALL wrf_message ( program_name )
364	CALL wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain fine ' )
365	CALL alloc_and_configure_domain ( domain_id = 2 , &
366	grid = nested_grid , &
367	parent = parent_grid , &
368	kid = 1 )
369
370	CALL wrf_debug ( 100 , 'wrf: calling model_to_grid_config_rec ' )
371	CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
372	CALL wrf_debug ( 100 , 'wrf: calling set_scalar_indices_from_config ' )
373	CALL set_scalar_indices_from_config ( nested_grid%id , idum1, idum2 )
374
375	! Set up time initializations for the fine grid.
376
377	CALL Setup_Timekeeping ( nested_grid )
378	! Strictly speaking, nest stop time should come from model_config_rec...
379	CALL domain_clock_get( parent_grid, stop_timestr=stopTimeStr )
380	CALL domain_clock_set( nested_grid, &
381	current_timestr=current_date(1:19), &
382	stop_timestr=stopTimeStr , &
383	time_step_seconds= &
384	model_config_rec%interval_seconds )
385
386	! Generate an output file from this program, which will be an input file to WRF.
387
388	CALL nl_set_bdyfrq ( nested_grid%id , new_bdy_frq )
389	config_flags%bdyfrq = new_bdy_frq
390
391	#ifdef WRF_CHEM
392	nested_grid%chem_opt = parent_grid%chem_opt
393	nested_grid%chem_in_opt = parent_grid%chem_in_opt
394	#endif
395
396	! Initialize constants and 1d arrays in fine grid from the parent.
397
398	CALL init_domain_constants_em_ptr ( parent_grid , nested_grid )
399
400	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
401
402	CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfinput' )
403	CALL construct_filename1( outname , 'wrfinput' , nested_grid%id , 2 )
404	CALL open_w_dataset ( fido, TRIM(outname) , nested_grid , config_flags , output_model_input , "DATASET=INPUT", ierr )
405	IF ( ierr .NE. 0 ) THEN
406	WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(outname),' for reading ierr=',ierr
407	CALL WRF_ERROR_FATAL ( wrf_err_message )
408	ENDIF
409
410	! Various sizes that we need to be concerned about.
411
412	ids = nested_grid%sd31
413	ide = nested_grid%ed31
414	kds = nested_grid%sd32
415	kde = nested_grid%ed32
416	jds = nested_grid%sd33
417	jde = nested_grid%ed33
418
419	ims = nested_grid%sm31
420	ime = nested_grid%em31
421	kms = nested_grid%sm32
422	kme = nested_grid%em32
423	jms = nested_grid%sm33
424	jme = nested_grid%em33
425
426	ips = nested_grid%sp31
427	ipe = nested_grid%ep31
428	kps = nested_grid%sp32
429	kpe = nested_grid%ep32
430	jps = nested_grid%sp33
431	jpe = nested_grid%ep33
432
433
434	print *, ids , ide , jds , jde , kds , kde
435	print *, ims , ime , jms , jme , kms , kme
436	print *, ips , ipe , jps , jpe , kps , kpe
437
438	spec_bdy_width = model_config_rec%spec_bdy_width
439	print *,'spec_bdy_width=',spec_bdy_width
440
441	! This is the space needed to save the current 3d data for use in computing
442	! the lateral boundary tendencies.
443
444	ALLOCATE ( ubdy3dtemp1(ims:ime,kms:kme,jms:jme) )
445	ALLOCATE ( vbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
446	ALLOCATE ( tbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
447	ALLOCATE ( pbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
448	ALLOCATE ( qbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
449	ALLOCATE ( mbdy2dtemp1(ims:ime,1:1, jms:jme) )
450	ALLOCATE ( ubdy3dtemp2(ims:ime,kms:kme,jms:jme) )
451	ALLOCATE ( vbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
452	ALLOCATE ( tbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
453	ALLOCATE ( pbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
454	ALLOCATE ( qbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
455	ALLOCATE ( mbdy2dtemp2(ims:ime,1:1, jms:jme) )
456	ALLOCATE ( cbdy3dtemp0(ims:ime,kms:kme,jms:jme,1:num_chem) )
457	ALLOCATE ( cbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
458	ALLOCATE ( cbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
459
460	END IF
461
462	CALL domain_clock_set( nested_grid, &
463	current_timestr=current_date(1:19), &
464	time_step_seconds= &
465	model_config_rec%interval_seconds )
466
467	! Do the horizontal interpolation.
468
469	nested_grid%imask_nostag = 1
470	nested_grid%imask_xstag = 1
471	nested_grid%imask_ystag = 1
472	nested_grid%imask_xystag = 1
473
474	CALL med_interp_domain ( head_grid , nested_grid )
475	nested_grid%ht_int = nested_grid%ht
476
477	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
478
479	IF ( time_loop .EQ. 1 ) THEN
480
481	! Dimension info for fine grid.
482
483	CALL get_ijk_from_grid ( nested_grid , &
484	nids, nide, njds, njde, nkds, nkde, &
485	nims, nime, njms, njme, nkms, nkme, &
486	nips, nipe, njps, njpe, nkps, nkpe )
487
488	! Store horizontally interpolated terrain in temp location
489
490	CALL store_terrain ( nested_grid%ht_fine , nested_grid%ht , &
491	nids , nide , njds , njde , 1 , 1 , &
492	nims , nime , njms , njme , 1 , 1 , &
493	nips , nipe , njps , njpe , 1 , 1 )
494
495	! Open the fine grid SI static file.
496
497	CALL construct_filename1( si_inpname , 'wrfndi' , nested_grid%id , 2 )
498	CALL wrf_debug ( 100 , 'med_sidata_input: calling open_r_dataset for ' // TRIM(si_inpname) )
499	CALL open_r_dataset ( idsi, TRIM(si_inpname) , nested_grid , config_flags , "DATASET=INPUT", ierr )
500	IF ( ierr .NE. 0 ) THEN
501	CALL wrf_error_fatal( 'real: error opening FG input for reading: ' // TRIM (si_inpname) )
502	END IF
503
504	! Input data.
505
506	CALL wrf_debug ( 100 , 'ndown_em: calling input_aux_model_input2' )
507	CALL input_aux_model_input2 ( idsi , nested_grid , config_flags , ierr )
508	nested_grid%ht_input = nested_grid%ht
509
510	! Close this fine grid static input file.
511
512	CALL wrf_debug ( 100 , 'ndown_em: closing fine grid static input' )
513	CALL close_dataset ( idsi , config_flags , "DATASET=INPUT" )
514
515	! Blend parent and nest field of terrain.
516
517	CALL blend_terrain ( nested_grid%ht_fine , nested_grid%ht , &
518	nids , nide , njds , njde , 1 , 1 , &
519	nims , nime , njms , njme , 1 , 1 , &
520	nips , nipe , njps , njpe , 1 , 1 )
521
522	nested_grid%ht_input = nested_grid%ht
523	nested_grid%ht_int = nested_grid%ht_fine
524
525	! We need a fine grid landuse in the interpolation. So we need to generate
526	! that field now.
527
528	IF ( ( nested_grid%ivgtyp(ips,jps) .GT. 0 ) .AND. &
529	( nested_grid%isltyp(ips,jps) .GT. 0 ) ) THEN
530	DO j = jps, MIN(jde-1,jpe)
531	DO i = ips, MIN(ide-1,ipe)
532	nested_grid% vegcat(i,j) = nested_grid%ivgtyp(i,j)
533	nested_grid%soilcat(i,j) = nested_grid%isltyp(i,j)
534	END DO
535	END DO
536
537	ELSE IF ( ( nested_grid% vegcat(ips,jps) .GT. 0.5 ) .AND. &
538	( nested_grid%soilcat(ips,jps) .GT. 0.5 ) ) THEN
539	DO j = jps, MIN(jde-1,jpe)
540	DO i = ips, MIN(ide-1,ipe)
541	nested_grid%ivgtyp(i,j) = NINT(nested_grid% vegcat(i,j))
542	nested_grid%isltyp(i,j) = NINT(nested_grid%soilcat(i,j))
543	END DO
544	END DO
545
546	ELSE
547	num_veg_cat = SIZE ( nested_grid%landusef , DIM=2 )
548	num_soil_top_cat = SIZE ( nested_grid%soilctop , DIM=2 )
549	num_soil_bot_cat = SIZE ( nested_grid%soilcbot , DIM=2 )
550
551	CALL land_percentages ( nested_grid%xland , &
552	nested_grid%landusef , nested_grid%soilctop , nested_grid%soilcbot , &
553	nested_grid%isltyp , nested_grid%ivgtyp , &
554	num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
555	ids , ide , jds , jde , kds , kde , &
556	ims , ime , jms , jme , kms , kme , &
557	ips , ipe , jps , jpe , kps , kpe , &
558	model_config_rec%iswater(nested_grid%id) )
559
560	END IF
561
562	DO j = jps, MIN(jde-1,jpe)
563	DO i = ips, MIN(ide-1,ipe)
564	nested_grid%lu_index(i,j) = nested_grid%ivgtyp(i,j)
565	END DO
566	END DO
567
568	#ifndef PLANET
569	CALL check_consistency ( nested_grid%ivgtyp , nested_grid%isltyp , nested_grid%landmask , &
570	ids , ide , jds , jde , kds , kde , &
571	ims , ime , jms , jme , kms , kme , &
572	ips , ipe , jps , jpe , kps , kpe , &
573	model_config_rec%iswater(nested_grid%id) )
574
575	CALL check_consistency2( nested_grid%ivgtyp , nested_grid%isltyp , nested_grid%landmask , &
576	nested_grid%tmn , nested_grid%tsk , nested_grid%sst , nested_grid%xland , &
577	nested_grid%tslb , nested_grid%smois , nested_grid%sh2o , &
578	config_flags%num_soil_layers , nested_grid%id , &
579	ids , ide , jds , jde , kds , kde , &
580	ims , ime , jms , jme , kms , kme , &
581	ips , ipe , jps , jpe , kps , kpe , &
582	model_config_rec%iswater(nested_grid%id) )
583	#endif
584
585	END IF
586
587	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
588
589	! We have 2 terrain elevations. One is from input and the other is from the
590	! the horizontal interpolation.
591
592	nested_grid%ht_fine = nested_grid%ht_input
593	nested_grid%ht = nested_grid%ht_int
594
595	! We have both the interpolated fields and the higher-resolution static fields. From these
596	! the rebalancing is now done. Note also that the field nested_grid%ht is now from the
597	! fine grid input file (after this call is completed).
598
599	CALL rebalance_driver ( nested_grid )
600
601	! Different things happen during the different time loops:
602	! first loop - write wrfinput file, close data set, copy files to holder arrays
603	! middle loops - diff 3d/2d arrays, compute and output bc
604	! last loop - diff 3d/2d arrays, compute and output bc, write wrfbdy file, close wrfbdy file
605
606	IF ( time_loop .EQ. 1 ) THEN
607
608	! Set the time info.
609
610	print *,'current_date = ',current_date
611	CALL domain_clock_set( nested_grid, &
612	current_timestr=current_date(1:19) )
613	#ifdef WRF_CHEM
614	!
615	! SEP Put in chemistry data
616	!
617	IF( nested_grid%chem_opt .NE. 0 ) then
618	! IF( nested_grid%chem_in_opt .EQ. 0 ) then
619	! Read the chemistry data from a previous wrf forecast (wrfout file)
620	! Generate chemistry data from a idealized vertical profile
621	! message = 'STARTING WITH BACKGROUND CHEMISTRY '
622	CALL wrf_message ( message )
623
624	! CALL input_chem_profile ( nested_grid )
625
626	if( nested_grid%bio_emiss_opt .eq. 2 )then
627	message = 'READING BEIS3.11 EMISSIONS DATA'
628	CALL wrf_message ( message )
629	CALL med_read_wrf_chem_bioemiss ( nested_grid , config_flags)
630	else IF( nested_grid%bio_emiss_opt == 3 ) THEN !shc
631	message = 'READING MEGAN 2 EMISSIONS DATA'
632	CALL wrf_message ( message )
633	CALL med_read_wrf_chem_bioemiss ( nested_grid , config_flags)
634	endif
635	! ELSE
636	! message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION'
637	! CALL wrf_message ( message )
638	! ENDIF
639	ENDIF
640	#endif
641
642	! Output the first time period of the data.
643
644	CALL output_model_input ( fido , nested_grid , config_flags , ierr )
645
646	CALL wrf_put_dom_ti_integer ( fido , 'MAP_PROJ' , map_proj , 1 , ierr )
647	! CALL wrf_put_dom_ti_real ( fido , 'DX' , dx , 1 , ierr )
648	! CALL wrf_put_dom_ti_real ( fido , 'DY' , dy , 1 , ierr )
649	CALL wrf_put_dom_ti_real ( fido , 'CEN_LAT' , cen_lat , 1 , ierr )
650	CALL wrf_put_dom_ti_real ( fido , 'CEN_LON' , cen_lon , 1 , ierr )
651	CALL wrf_put_dom_ti_real ( fido , 'TRUELAT1' , truelat1 , 1 , ierr )
652	CALL wrf_put_dom_ti_real ( fido , 'TRUELAT2' , truelat2 , 1 , ierr )
653	CALL wrf_put_dom_ti_real ( fido , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , ierr )
654	CALL wrf_put_dom_ti_real ( fido , 'STAND_LON' , stand_lon , 1 , ierr )
655	CALL wrf_put_dom_ti_integer ( fido , 'ISWATER' , iswater , 1 , ierr )
656
657	! These change if the initial time for the nest is not the same as the
658	! first time period in the WRF output file.
659	! Now that we know the starting date, we need to set the GMT, JULYR, and JULDAY
660	! values for the global attributes. This call is based on the setting of the
661	! current_date string.
662
663	CALL geth_julgmt ( julyr , julday , gmt)
664	CALL nl_set_julyr ( nested_grid%id , julyr )
665	CALL nl_set_julday ( nested_grid%id , julday )
666	CALL nl_set_gmt ( nested_grid%id , gmt )
667	CALL wrf_put_dom_ti_real ( fido , 'GMT' , gmt , 1 , ierr )
668	CALL wrf_put_dom_ti_integer ( fido , 'JULYR' , julyr , 1 , ierr )
669	CALL wrf_put_dom_ti_integer ( fido , 'JULDAY' , julday , 1 , ierr )
670	print *,'current_date =',current_date
671	print *,'julyr=',julyr
672	print *,'julday=',julday
673	print *,'gmt=',gmt
674
675	! Close the input (wrfout_d01_000000, for example) file. That's right, the
676	! input is an output file. Who'd've thunk.
677
678	CALL close_dataset ( fido , config_flags , "DATASET=INPUT" )
679
680	! We need to save the 3d/2d data to compute a difference during the next loop. Couple the
681	! 3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor.
682
683	! u, theta, h, scalars coupled with my, v coupled with mx
684	CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp1 , nested_grid%u_2 , &
685	'u' , nested_grid%msfuy , &
686	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
687	CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp1 , nested_grid%v_2 , &
688	'v' , nested_grid%msfvx , &
689	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
690	CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp1 , nested_grid%t_2 , &
691	't' , nested_grid%msfty , &
692	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
693	CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp1 , nested_grid%ph_2 , &
694	'h' , nested_grid%msfty , &
695	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
696	CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp1 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV) , &
697	't' , nested_grid%msfty , &
698	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
699
700	DO j = jps , jpe
701	DO i = ips , ipe
702	mbdy2dtemp1(i,1,j) = nested_grid%mu_2(i,j)
703	END DO
704	END DO
705
706	! There are 2 components to the lateral boundaries. First, there is the starting
707	! point of this time period - just the outer few rows and columns.
708
709	CALL stuff_bdy ( ubdy3dtemp1 , nested_grid%u_bxs, nested_grid%u_bxe, &
710	nested_grid%u_bys, nested_grid%u_bye, &
711	'U' , spec_bdy_width , &
712	ids , ide , jds , jde , kds , kde , &
713	ims , ime , jms , jme , kms , kme , &
714	ips , ipe , jps , jpe , kps , kpe )
715	CALL stuff_bdy ( vbdy3dtemp1 , nested_grid%v_bxs, nested_grid%v_bxe, &
716	nested_grid%v_bys, nested_grid%v_bye, &
717	'V' , spec_bdy_width , &
718	ids , ide , jds , jde , kds , kde , &
719	ims , ime , jms , jme , kms , kme , &
720	ips , ipe , jps , jpe , kps , kpe )
721	CALL stuff_bdy ( tbdy3dtemp1 , nested_grid%t_bxs, nested_grid%t_bxe, &
722	nested_grid%t_bys, nested_grid%t_bye, &
723	'T' , spec_bdy_width , &
724	ids , ide , jds , jde , kds , kde , &
725	ims , ime , jms , jme , kms , kme , &
726	ips , ipe , jps , jpe , kps , kpe )
727	CALL stuff_bdy ( pbdy3dtemp1 , nested_grid%ph_bxs, nested_grid%ph_bxe, &
728	nested_grid%ph_bys, nested_grid%ph_bye, &
729	'W' , spec_bdy_width , &
730	ids , ide , jds , jde , kds , kde , &
731	ims , ime , jms , jme , kms , kme , &
732	ips , ipe , jps , jpe , kps , kpe )
733	CALL stuff_bdy ( qbdy3dtemp1 , nested_grid%moist_bxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
734	nested_grid%moist_bxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
735	nested_grid%moist_bys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
736	nested_grid%moist_bye(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
737	'T' , spec_bdy_width , &
738	ids , ide , jds , jde , kds , kde , &
739	ims , ime , jms , jme , kms , kme , &
740	ips , ipe , jps , jpe , kps , kpe )
741	CALL stuff_bdy ( mbdy2dtemp1 , nested_grid%mu_bxs, nested_grid%mu_bxe, &
742	nested_grid%mu_bys, nested_grid%mu_bye, &
743	'M' , spec_bdy_width , &
744	ids , ide , jds , jde , 1 , 1 , &
745	ims , ime , jms , jme , 1 , 1 , &
746	ips , ipe , jps , jpe , 1 , 1 )
747	#ifdef WRF_CHEM
748	do nvchem=1,num_chem
749	! if(nvchem.eq.p_o3)then
750	! write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5),nvchem
751	! endif
752	cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
753	! if(nvchem.eq.p_o3)then
754	! write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5)
755	! endif
756	CALL stuff_bdy ( cbdy3dtemp1 , nested_grid%chem_bxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
757	nested_grid%chem_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
758	nested_grid%chem_bys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
759	nested_grid%chem_bye(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
760	'T' , spec_bdy_width , &
761	ids , ide , jds , jde , kds , kde , &
762	ims , ime , jms , jme , kms , kme , &
763	ips , ipe , jps , jpe , kps , kpe )
764	cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)
765	! if(nvchem.eq.p_o3)then
766	! write(0,*)'filled ch_b',time_loop,cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
767	! endif
768	enddo
769	#endif
770	ELSE IF ( ( time_loop .GT. 1 ) .AND. ( time_loop .LT. time_loop_max ) ) THEN
771
772	! u, theta, h, scalars coupled with my, v coupled with mx
773	CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp2 , nested_grid%u_2 , &
774	'u' , nested_grid%msfuy , &
775	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
776	CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp2 , nested_grid%v_2 , &
777	'v' , nested_grid%msfvx , &
778	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
779	CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp2 , nested_grid%t_2 , &
780	't' , nested_grid%msfty , &
781	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
782	CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp2 , nested_grid%ph_2 , &
783	'h' , nested_grid%msfty , &
784	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
785	CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp2 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV) , &
786	't' , nested_grid%msfty , &
787	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
788
789	DO j = jps , jpe
790	DO i = ips , ipe
791	mbdy2dtemp2(i,1,j) = nested_grid%mu_2(i,j)
792	END DO
793	END DO
794
795	! During all of the loops after the first loop, we first compute the boundary
796	! tendencies with the current data values and the previously save information
797	! stored in the *bdy3dtemp1 arrays.
798
799	CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , new_bdy_frq , &
800	nested_grid%u_btxs, nested_grid%u_btxe , &
801	nested_grid%u_btys, nested_grid%u_btye , &
802	'U' , &
803	spec_bdy_width , &
804	ids , ide , jds , jde , kds , kde , &
805	ims , ime , jms , jme , kms , kme , &
806	ips , ipe , jps , jpe , kps , kpe )
807	CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , new_bdy_frq , &
808	nested_grid%v_btxs, nested_grid%v_btxe , &
809	nested_grid%v_btys, nested_grid%v_btye , &
810	'V' , &
811	spec_bdy_width , &
812	ids , ide , jds , jde , kds , kde , &
813	ims , ime , jms , jme , kms , kme , &
814	ips , ipe , jps , jpe , kps , kpe )
815	CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , new_bdy_frq , &
816	nested_grid%t_btxs, nested_grid%t_btxe , &
817	nested_grid%t_btys, nested_grid%t_btye , &
818	'T' , &
819	spec_bdy_width , &
820	ids , ide , jds , jde , kds , kde , &
821	ims , ime , jms , jme , kms , kme , &
822	ips , ipe , jps , jpe , kps , kpe )
823	CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , new_bdy_frq , &
824	nested_grid%ph_btxs, nested_grid%ph_btxe , &
825	nested_grid%ph_btys, nested_grid%ph_btye , &
826	'W' , &
827	spec_bdy_width , &
828	ids , ide , jds , jde , kds , kde , &
829	ims , ime , jms , jme , kms , kme , &
830	ips , ipe , jps , jpe , kps , kpe )
831	CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , new_bdy_frq , &
832	nested_grid%moist_btxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
833	nested_grid%moist_btxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
834	nested_grid%moist_btys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
835	nested_grid%moist_btye(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
836	'T' , &
837	spec_bdy_width , &
838	ids , ide , jds , jde , kds , kde , &
839	ims , ime , jms , jme , kms , kme , &
840	ips , ipe , jps , jpe , kps , kpe )
841	CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , &
842	nested_grid%mu_btxs, nested_grid%mu_btxe , &
843	nested_grid%mu_btys, nested_grid%mu_btye , &
844	'M' , &
845	spec_bdy_width , &
846	ids , ide , jds , jde , 1 , 1 , &
847	ims , ime , jms , jme , 1 , 1 , &
848	ips , ipe , jps , jpe , 1 , 1 )
849	#ifdef WRF_CHEM
850	do nvchem=1,num_chem
851	cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
852	cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
853	! if(nvchem.eq.p_o3)then
854	! write(0,*)'fill 1ch_b2',time_loop,cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
855	! endif
856	CALL stuff_bdytend ( cbdy3dtemp2 , cbdy3dtemp1 , new_bdy_frq , &
857	nested_grid%chem_btxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
858	nested_grid%chem_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
859	nested_grid%chem_btys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
860	nested_grid%chem_btye(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
861	'T' , &
862	spec_bdy_width , &
863	ids , ide , jds , jde , kds , kde , &
864	ims , ime , jms , jme , kms , kme , &
865	ips , ipe , jps , jpe , kps , kpe )
866	cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)
867	! if(nvchem.eq.p_o3)then
868	! write(0,*)'fill 2ch_b2',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
869	! endif
870	enddo
871	#endif
872	IF ( time_loop .EQ. 2 ) THEN
873
874	! Generate an output file from this program, which will be an input file to WRF.
875
876	CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfbdy' )
877	CALL construct_filename1( bdyname , 'wrfbdy' , nested_grid%id , 2 )
878	CALL open_w_dataset ( fidb, TRIM(bdyname) , nested_grid , config_flags , output_boundary , &
879	"DATASET=BOUNDARY", ierr )
880	IF ( ierr .NE. 0 ) THEN
881	WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(bdyname),' for reading ierr=',ierr
882	CALL WRF_ERROR_FATAL ( wrf_err_message )
883	ENDIF
884
885	END IF
886
887	! Both pieces of the boundary data are now available to be written.
888
889	CALL domain_clock_set( nested_grid, &
890	current_timestr=current_date(1:19) )
891	temp24= current_date
892	temp24b=start_date_hold
893	start_date = start_date_hold
894	CALL geth_newdate ( temp19 , temp24b(1:19) , (time_loop-2) * model_config_rec%interval_seconds )
895	current_date = temp19 // '.0000'
896	CALL geth_julgmt ( julyr , julday , gmt)
897	CALL nl_set_julyr ( nested_grid%id , julyr )
898	CALL nl_set_julday ( nested_grid%id , julday )
899	CALL nl_set_gmt ( nested_grid%id , gmt )
900	CALL wrf_put_dom_ti_real ( fidb , 'GMT' , gmt , 1 , ierr )
901	CALL wrf_put_dom_ti_integer ( fidb , 'JULYR' , julyr , 1 , ierr )
902	CALL wrf_put_dom_ti_integer ( fidb , 'JULDAY' , julday , 1 , ierr )
903	CALL domain_clock_set( nested_grid, &
904	current_timestr=current_date(1:19) )
905	print *,'bdy time = ',time_loop-1,' bdy date = ',current_date,' ',start_date
906	CALL output_boundary ( fidb , nested_grid , config_flags , ierr )
907	current_date = temp24
908	start_date = temp24b
909	CALL domain_clock_set( nested_grid, &
910	current_timestr=current_date(1:19) )
911
912	IF ( time_loop .EQ. 2 ) THEN
913	CALL wrf_put_dom_ti_real ( fidb , 'BDYFRQ' , new_bdy_frq , 1 , ierr )
914	END IF
915
916	! We need to save the 3d data to compute a difference during the next loop. Couple the
917	! 3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor.
918	! We load up the boundary data again for use in the next loop.
919
920	DO j = jps , jpe
921	DO k = kps , kpe
922	DO i = ips , ipe
923	ubdy3dtemp1(i,k,j) = ubdy3dtemp2(i,k,j)
924	vbdy3dtemp1(i,k,j) = vbdy3dtemp2(i,k,j)
925	tbdy3dtemp1(i,k,j) = tbdy3dtemp2(i,k,j)
926	pbdy3dtemp1(i,k,j) = pbdy3dtemp2(i,k,j)
927	qbdy3dtemp1(i,k,j) = qbdy3dtemp2(i,k,j)
928	END DO
929	END DO
930	END DO
931
932	DO j = jps , jpe
933	DO i = ips , ipe
934	mbdy2dtemp1(i,1,j) = mbdy2dtemp2(i,1,j)
935	END DO
936	END DO
937
938	! There are 2 components to the lateral boundaries. First, there is the starting
939	! point of this time period - just the outer few rows and columns.
940
941	CALL stuff_bdy ( ubdy3dtemp1 , &
942	nested_grid%u_bxs, nested_grid%u_bxe , &
943	nested_grid%u_bys, nested_grid%u_bye , &
944	'U' , spec_bdy_width , &
945	ids , ide , jds , jde , kds , kde , &
946	ims , ime , jms , jme , kms , kme , &
947	ips , ipe , jps , jpe , kps , kpe )
948	CALL stuff_bdy ( vbdy3dtemp1 , &
949	nested_grid%v_bxs, nested_grid%v_bxe , &
950	nested_grid%v_bys, nested_grid%v_bye , &
951	'V' , spec_bdy_width , &
952	ids , ide , jds , jde , kds , kde , &
953	ims , ime , jms , jme , kms , kme , &
954	ips , ipe , jps , jpe , kps , kpe )
955	CALL stuff_bdy ( tbdy3dtemp1 , &
956	nested_grid%t_bxs, nested_grid%t_bxe , &
957	nested_grid%t_bys, nested_grid%t_bye , &
958	'T' , spec_bdy_width , &
959	ids , ide , jds , jde , kds , kde , &
960	ims , ime , jms , jme , kms , kme , &
961	ips , ipe , jps , jpe , kps , kpe )
962	CALL stuff_bdy ( pbdy3dtemp1 , &
963	nested_grid%ph_bxs, nested_grid%ph_bxe , &
964	nested_grid%ph_bys, nested_grid%ph_bye , &
965	'W' , spec_bdy_width , &
966	ids , ide , jds , jde , kds , kde , &
967	ims , ime , jms , jme , kms , kme , &
968	ips , ipe , jps , jpe , kps , kpe )
969	CALL stuff_bdy ( qbdy3dtemp1 , &
970	nested_grid%moist_bxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
971	nested_grid%moist_bxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
972	nested_grid%moist_bys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
973	nested_grid%moist_bye(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
974	'T' , spec_bdy_width , &
975	ids , ide , jds , jde , kds , kde , &
976	ims , ime , jms , jme , kms , kme , &
977	ips , ipe , jps , jpe , kps , kpe )
978	#ifdef WRF_CHEM
979	do nvchem=1,num_chem
980	cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
981	! if(nvchem.eq.p_o3)then
982	! write(0,*)'fill 2ch_b3',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
983	! endif
984	CALL stuff_bdy ( cbdy3dtemp1 , &
985	nested_grid%chem_bxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
986	nested_grid%chem_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
987	nested_grid%chem_bys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
988	nested_grid%chem_bye(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
989	'T' , spec_bdy_width , &
990	ids , ide , jds , jde , kds , kde , &
991	ims , ime , jms , jme , kms , kme , &
992	ips , ipe , jps , jpe , kps , kpe )
993	! cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)
994	! if(nvchem.eq.p_o3)then
995	! write(0,*)'fill 2ch_b3',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
996	! endif
997	enddo
998	#endif
999	CALL stuff_bdy ( mbdy2dtemp1 , &
1000	nested_grid%mu_bxs, nested_grid%mu_bxe , &
1001	nested_grid%mu_bys, nested_grid%mu_bye , &
1002	'M' , spec_bdy_width , &
1003	ids , ide , jds , jde , 1 , 1 , &
1004	ims , ime , jms , jme , 1 , 1 , &
1005	ips , ipe , jps , jpe , 1 , 1 )
1006
1007	ELSE IF ( time_loop .EQ. time_loop_max ) THEN
1008
1009	! u, theta, h, scalars coupled with my, v coupled with mx
1010	CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp2 , nested_grid%u_2 , &
1011	'u' , nested_grid%msfuy , &
1012	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1013	CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp2 , nested_grid%v_2 , &
1014	'v' , nested_grid%msfvx , &
1015	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1016	CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp2 , nested_grid%t_2 , &
1017	't' , nested_grid%msfty , &
1018	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1019	CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp2 , nested_grid%ph_2 , &
1020	'h' , nested_grid%msfty , &
1021	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1022	CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp2 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV) , &
1023	't' , nested_grid%msfty , &
1024	ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1025	mbdy2dtemp2(:,1,:) = nested_grid%mu_2(:,:)
1026
1027	! During all of the loops after the first loop, we first compute the boundary
1028	! tendencies with the current data values and the previously save information
1029	! stored in the *bdy3dtemp1 arrays.
1030	#ifdef WRF_CHEM
1031	do nvchem=1,num_chem
1032	cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
1033	cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
1034	! if(nvchem.eq.p_o3)then
1035	! write(0,*)'fill 1ch_b4',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
1036	! endif
1037	CALL stuff_bdytend ( cbdy3dtemp2 , cbdy3dtemp1 , new_bdy_frq , &
1038	nested_grid%chem_btxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
1039	nested_grid%chem_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
1040	nested_grid%chem_btys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
1041	nested_grid%chem_btye(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
1042	'T' , &
1043	spec_bdy_width , &
1044	ids , ide , jds , jde , kds , kde , &
1045	ims , ime , jms , jme , kms , kme , &
1046	ips , ipe , jps , jpe , kps , kpe )
1047	cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)
1048	! if(nvchem.eq.p_o3)then
1049	! write(0,*)'fill 2ch_b4',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
1050	! endif
1051	enddo
1052	#endif
1053
1054	CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , new_bdy_frq , &
1055	nested_grid%u_btxs , nested_grid%u_btxe , &
1056	nested_grid%u_btys , nested_grid%u_btye , &
1057	'U' , &
1058	spec_bdy_width , &
1059	ids , ide , jds , jde , kds , kde , &
1060	ims , ime , jms , jme , kms , kme , &
1061	ips , ipe , jps , jpe , kps , kpe )
1062	CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , new_bdy_frq , &
1063	nested_grid%v_btxs , nested_grid%v_btxe , &
1064	nested_grid%v_btys , nested_grid%v_btye , &
1065	'V' , &
1066	spec_bdy_width , &
1067	ids , ide , jds , jde , kds , kde , &
1068	ims , ime , jms , jme , kms , kme , &
1069	ips , ipe , jps , jpe , kps , kpe )
1070	CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , new_bdy_frq , &
1071	nested_grid%t_btxs , nested_grid%t_btxe , &
1072	nested_grid%t_btys , nested_grid%t_btye , &
1073	'T' , &
1074	spec_bdy_width , &
1075	ids , ide , jds , jde , kds , kde , &
1076	ims , ime , jms , jme , kms , kme , &
1077	ips , ipe , jps , jpe , kps , kpe )
1078	CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , new_bdy_frq , &
1079	nested_grid%ph_btxs , nested_grid%ph_btxe , &
1080	nested_grid%ph_btys , nested_grid%ph_btye , &
1081	'W' , &
1082	spec_bdy_width , &
1083	ids , ide , jds , jde , kds , kde , &
1084	ims , ime , jms , jme , kms , kme , &
1085	ips , ipe , jps , jpe , kps , kpe )
1086	CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , new_bdy_frq , &
1087	nested_grid%moist_btxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV) , &
1088	nested_grid%moist_btxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV) , &
1089	nested_grid%moist_btys(ims:ime,kms:kme,1:spec_bdy_width,P_QV) , &
1090	nested_grid%moist_btye(ims:ime,kms:kme,1:spec_bdy_width,P_QV) , &
1091	'T' , &
1092	spec_bdy_width , &
1093	ids , ide , jds , jde , kds , kde , &
1094	ims , ime , jms , jme , kms , kme , &
1095	ips , ipe , jps , jpe , kps , kpe )
1096	CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , &
1097	nested_grid%mu_btxs , nested_grid%mu_btxe , &
1098	nested_grid%mu_btys , nested_grid%mu_btye , &
1099	'M' , &
1100	spec_bdy_width , &
1101	ids , ide , jds , jde , 1 , 1 , &
1102	ims , ime , jms , jme , 1 , 1 , &
1103	ips , ipe , jps , jpe , 1 , 1 )
1104
1105	IF ( time_loop .EQ. 2 ) THEN
1106
1107	! Generate an output file from this program, which will be an input file to WRF.
1108
1109	CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfbdy' )
1110	CALL construct_filename1( bdyname , 'wrfbdy' , nested_grid%id , 2 )
1111	CALL open_w_dataset ( fidb, TRIM(bdyname) , nested_grid , config_flags , output_boundary , &
1112	"DATASET=BOUNDARY", ierr )
1113	IF ( ierr .NE. 0 ) THEN
1114	WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(bdyname),' for reading ierr=',ierr
1115	CALL WRF_ERROR_FATAL ( wrf_err_message )
1116	ENDIF
1117
1118	END IF
1119
1120	! Both pieces of the boundary data are now available to be written.
1121
1122	CALL domain_clock_set( nested_grid, &
1123	current_timestr=current_date(1:19) )
1124	temp24= current_date
1125	temp24b=start_date_hold
1126	start_date = start_date_hold
1127	CALL geth_newdate ( temp19 , temp24b(1:19) , (time_loop-2) * model_config_rec%interval_seconds )
1128	current_date = temp19 // '.0000'
1129	CALL geth_julgmt ( julyr , julday , gmt)
1130	CALL nl_set_julyr ( nested_grid%id , julyr )
1131	CALL nl_set_julday ( nested_grid%id , julday )
1132	CALL nl_set_gmt ( nested_grid%id , gmt )
1133	CALL wrf_put_dom_ti_real ( fidb , 'GMT' , gmt , 1 , ierr )
1134	CALL wrf_put_dom_ti_integer ( fidb , 'JULYR' , julyr , 1 , ierr )
1135	CALL wrf_put_dom_ti_integer ( fidb , 'JULDAY' , julday , 1 , ierr )
1136	CALL domain_clock_set( nested_grid, &
1137	current_timestr=current_date(1:19) )
1138	CALL output_boundary ( fidb , nested_grid , config_flags , ierr )
1139	current_date = temp24
1140	start_date = temp24b
1141	CALL domain_clock_set( nested_grid, &
1142	current_timestr=current_date(1:19) )
1143
1144	IF ( time_loop .EQ. 2 ) THEN
1145	CALL wrf_put_dom_ti_real ( fidb , 'BDYFRQ' , new_bdy_frq , 1 , ierr )
1146	END IF
1147
1148	! Since this is the last time through here, we need to close the boundary file.
1149
1150	CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
1151	CALL close_dataset ( fidb , config_flags , "DATASET=BOUNDARY" )
1152
1153
1154	END IF
1155
1156	! Process which time now?
1157
1158	END DO big_time_loop_thingy
1159
1160	CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
1161	CALL med_shutdown_io ( parent_grid , config_flags )
1162
1163	CALL wrf_debug ( 0 , 'ndown_em: SUCCESS COMPLETE NDOWN_EM INIT' )
1164
1165	CALL wrf_shutdown
1166
1167	CALL WRFU_Finalize( rc=rc )
1168
1169	END PROGRAM ndown_em
1170
1171	SUBROUTINE land_percentages ( xland , &
1172	landuse_frac , soil_top_cat , soil_bot_cat , &
1173	isltyp , ivgtyp , &
1174	num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
1175	ids , ide , jds , jde , kds , kde , &
1176	ims , ime , jms , jme , kms , kme , &
1177	its , ite , jts , jte , kts , kte , &
1178	iswater )
1179	USE module_soil_pre
1180
1181	IMPLICIT NONE
1182
1183	INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1184	ims , ime , jms , jme , kms , kme , &
1185	its , ite , jts , jte , kts , kte , &
1186	iswater
1187
1188	INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
1189	REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac
1190	REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat
1191	REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat
1192	INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
1193	REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: xland
1194
1195	CALL process_percent_cat_new ( xland , &
1196	landuse_frac , soil_top_cat , soil_bot_cat , &
1197	isltyp , ivgtyp , &
1198	num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
1199	ids , ide , jds , jde , kds , kde , &
1200	ims , ime , jms , jme , kms , kme , &
1201	its , ite , jts , jte , kts , kte , &
1202	iswater )
1203
1204	END SUBROUTINE land_percentages
1205
1206	SUBROUTINE check_consistency ( ivgtyp , isltyp , landmask , &
1207	ids , ide , jds , jde , kds , kde , &
1208	ims , ime , jms , jme , kms , kme , &
1209	its , ite , jts , jte , kts , kte , &
1210	iswater )
1211
1212	IMPLICIT NONE
1213
1214	INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1215	ims , ime , jms , jme , kms , kme , &
1216	its , ite , jts , jte , kts , kte , &
1217	iswater
1218	INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: isltyp , ivgtyp
1219	REAL , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: landmask
1220
1221	LOGICAL :: oops
1222	INTEGER :: oops_count , i , j
1223
1224	oops = .FALSE.
1225	oops_count = 0
1226
1227	DO j = jts, MIN(jde-1,jte)
1228	DO i = its, MIN(ide-1,ite)
1229	IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater ) ) .OR. &
1230	( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater ) ) ) THEN
1231	print *,'mismatch in landmask and veg type'
1232	print *,'i,j=',i,j, ' landmask =',NINT(landmask(i,j)),' ivgtyp=',ivgtyp(i,j)
1233	oops = .TRUE.
1234	oops_count = oops_count + 1
1235	landmask(i,j) = 0
1236	ivgtyp(i,j)=16
1237	isltyp(i,j)=14
1238	END IF
1239	END DO
1240	END DO
1241
1242	IF ( oops ) THEN
1243	CALL wrf_debug( 0, 'mismatch in check_consistency, turned to water points, be careful' )
1244	END IF
1245
1246	END SUBROUTINE check_consistency
1247
1248	SUBROUTINE check_consistency2( ivgtyp , isltyp , landmask , &
1249	tmn , tsk , sst , xland , &
1250	tslb , smois , sh2o , &
1251	num_soil_layers , id , &
1252	ids , ide , jds , jde , kds , kde , &
1253	ims , ime , jms , jme , kms , kme , &
1254	its , ite , jts , jte , kts , kte , &
1255	iswater )
1256
1257	USE module_configure
1258	USE module_optional_input
1259
1260	INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1261	ims , ime , jms , jme , kms , kme , &
1262	its , ite , jts , jte , kts , kte
1263	INTEGER , INTENT(IN) :: num_soil_layers , id
1264
1265	INTEGER , DIMENSION(ims:ime,jms:jme) :: ivgtyp , isltyp
1266	REAL , DIMENSION(ims:ime,jms:jme) :: landmask , tmn , tsk , sst , xland
1267	REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) :: tslb , smois , sh2o
1268
1269	INTEGER :: oops1 , oops2
1270	INTEGER :: i , j , k
1271
1272	fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(id) )
1273
1274	CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME )
1275	DO j = jts, MIN(jde-1,jte)
1276	DO i = its, MIN(ide-1,ite)
1277	IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
1278	tmn(i,j) = sst(i,j)
1279	tsk(i,j) = sst(i,j)
1280	ELSE IF ( landmask(i,j) .LT. 0.5 ) THEN
1281	tmn(i,j) = tsk(i,j)
1282	END IF
1283	END DO
1284	END DO
1285	END SELECT fix_tsk_tmn
1286
1287	! Is the TSK reasonable?
1288
1289	DO j = jts, MIN(jde-1,jte)
1290	DO i = its, MIN(ide-1,ite)
1291	IF ( tsk(i,j) .LT. 170 .or. tsk(i,j) .GT. 400. ) THEN
1292	print *,'error in the TSK'
1293	print *,'i,j=',i,j
1294	print *,'landmask=',landmask(i,j)
1295	print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1296	if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
1297	tsk(i,j)=tmn(i,j)
1298	else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1299	tsk(i,j)=sst(i,j)
1300	else
1301	CALL wrf_error_fatal ( 'TSK unreasonable' )
1302	end if
1303	END IF
1304	END DO
1305	END DO
1306
1307	! Is the TMN reasonable?
1308
1309	DO j = jts, MIN(jde-1,jte)
1310	DO i = its, MIN(ide-1,ite)
1311	IF ( ( ( tmn(i,j) .LT. 170. ) .OR. ( tmn(i,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
1312	print *,'error in the TMN'
1313	print *,'i,j=',i,j
1314	print *,'landmask=',landmask(i,j)
1315	print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1316	if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
1317	tmn(i,j)=tsk(i,j)
1318	else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1319	tmn(i,j)=sst(i,j)
1320	else
1321	CALL wrf_error_fatal ( 'TMN unreasonable' )
1322	endif
1323	END IF
1324	END DO
1325	END DO
1326
1327	! Is the TSLB reasonable?
1328
1329	DO j = jts, MIN(jde-1,jte)
1330	DO i = its, MIN(ide-1,ite)
1331	IF ( ( ( tslb(i,1,j) .LT. 170. ) .OR. ( tslb(i,1,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
1332	print *,'error in the TSLB'
1333	print *,'i,j=',i,j
1334	print *,'landmask=',landmask(i,j)
1335	print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1336	print *,'tslb = ',tslb(i,:,j)
1337	print *,'old smois = ',smois(i,:,j)
1338	DO l = 1 , num_soil_layers
1339	sh2o(i,l,j) = 0.0
1340	END DO
1341	DO l = 1 , num_soil_layers
1342	smois(i,l,j) = 0.3
1343	END DO
1344	if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
1345	DO l = 1 , num_soil_layers
1346	tslb(i,l,j)=tsk(i,j)
1347	END DO
1348	else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1349	DO l = 1 , num_soil_layers
1350	tslb(i,l,j)=sst(i,j)
1351	END DO
1352	else if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
1353	DO l = 1 , num_soil_layers
1354	tslb(i,l,j)=tmn(i,j)
1355	END DO
1356	else
1357	CALL wrf_error_fatal ( 'TSLB unreasonable' )
1358	endif
1359	END IF
1360	END DO
1361	END DO
1362
1363	! Let us make sure (again) that the landmask and the veg/soil categories match.
1364
1365	oops1=0
1366	oops2=0
1367	DO j = jts, MIN(jde-1,jte)
1368	DO i = its, MIN(ide-1,ite)
1369	IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater .OR. isltyp(i,j) .NE. 14 ) ) .OR. &
1370	( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater .OR. isltyp(i,j) .EQ. 14 ) ) ) THEN
1371	IF ( tslb(i,1,j) .GT. 1. ) THEN
1372	oops1=oops1+1
1373	ivgtyp(i,j) = 5
1374	isltyp(i,j) = 8
1375	landmask(i,j) = 1
1376	xland(i,j) = 1
1377	ELSE IF ( sst(i,j) .GT. 1. ) THEN
1378	oops2=oops2+1
1379	ivgtyp(i,j) = iswater
1380	isltyp(i,j) = 14
1381	landmask(i,j) = 0
1382	xland(i,j) = 2
1383	ELSE
1384	print *,'the landmask and soil/veg cats do not match'
1385	print *,'i,j=',i,j
1386	print *,'landmask=',landmask(i,j)
1387	print *,'ivgtyp=',ivgtyp(i,j)
1388	print *,'isltyp=',isltyp(i,j)
1389	print *,'iswater=', iswater
1390	print *,'tslb=',tslb(i,:,j)
1391	print *,'sst=',sst(i,j)
1392	CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' )
1393	END IF
1394	END IF
1395	END DO
1396	END DO
1397	if (oops1.gt.0) then
1398	print *,'points artificially set to land : ',oops1
1399	endif
1400	if(oops2.gt.0) then
1401	print *,'points artificially set to water: ',oops2
1402	endif
1403
1404	END SUBROUTINE check_consistency2
1405
1406	SUBROUTINE init_domain_constants_em_ptr ( parent , nest )
1407	USE module_domain
1408	USE module_configure
1409	IMPLICIT NONE
1410	TYPE(domain), POINTER :: parent , nest
1411	INTERFACE
1412	SUBROUTINE init_domain_constants_em ( parent , nest )
1413	USE module_domain
1414	USE module_configure
1415	TYPE(domain) :: parent , nest
1416	END SUBROUTINE init_domain_constants_em
1417	END INTERFACE
1418	CALL init_domain_constants_em ( parent , nest )
1419	END SUBROUTINE init_domain_constants_em_ptr

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

Download in other formats:

Original Format