Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

ndown_em.F @ 3576

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

Rev	Line
[2759]	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