Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

ndown_em.F @ 2498

Last change on this file since 2498 was 11, checked in by aslmd, 14 years ago
spiga@svn-planeto:ajoute le modele meso-echelle martien
File size: 64.0 KB

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

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

Download in other formats:

Original Format