Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

nup_em.F @ 3605

Last change on this file since 3605 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: 35.5 KB

Rev	Line
[2759]	1	!WRF:DRIVER_LAYER:MAIN
	2	!
	3
	4	! "Nest up" program in WRFV2.
	5	!
	6	! Description:
	7	!
	8	! The nest up (nup.exe) program reads from wrfout_d02_<date> files for
	9	! the nest and generates wrfout_d01_<date> files for the same periods as
	10	! are in the input files. The fields in the output are the fields in the
	11	! input for state variables that have 'h' and 'u' in the I/O string of
	12	! the Registry. In other words, these are the fields that are normally
	13	! fed back from nest->parent during 2-way nesting. It will read and
	14	! output over multiple files of nest data and generate an equivalent
	15	! number of files of parent data. The dimensions of the fields in the
	16	! output are the size of the nest fields divided by the nesting ratio.
	17	!
	18	! Source file: main/nup_em.F
	19	!
	20	! Compile with WRF: compile em_real
	21	!
	22	! Resulting executable:
	23	!
	24	! main/nup.exe
	25	! -and-
	26	! symbolic link in test/em_real/nup.exe
	27	!
	28	! Run as: nup.exe (no arguments)
	29	!
	30	! Namelist information:
	31	!
	32	! Nup.exe uses the same namelist as a nested run of the wrf.exe.
	33	! Important settings are:
	34	!
	35	! &time_control
	36	!
	37	! start_* <start time information for both domains>
	38	! end_* <start time information for both domains>
	39	! history_interval <interval between frames in input/output files>
	40	! frames_per_outfile <number of frames in input/output files>
	41	! io_form_history <2 for NetCDF>
	42	!
	43	! &domains
	44	! ...
	45	! max_dom <number of domains; must be 2>
	46	! e_we <col 2 is size of nested grid in west-east>
	47	! <col 1 is ignored in the namelist>
	48	! e_sn <col 2 is size of nested grid in south-north>
	49	! <col 1 is ignored in the namelist>
	50	! parent_grid_ratio <col 2 is nesting ratio in both dims>
	51	! feedback <must be 1>
	52	! smooth_option <recommend 0>
	53	!
	54	! &physics
	55	! <all options in this section should be the same
	56	! as the run that generated the nest data>
	57	!
	58	! created: JM 2006 01 25
	59
	60	PROGRAM nup_em
	61
	62	USE module_machine
	63	USE module_domain, only : domain, wrfu_timeinterval, alloc_and_configure_domain, &
	64	domain_clock_set
	65	USE module_initialize_real, only : wrfu_initialize
	66	USE module_integrate
	67	USE module_driver_constants
	68	USE module_configure, only : grid_config_rec_type, model_config_rec
	69	USE module_io_domain
	70	USE module_utility
	71
	72	USE module_timing
	73	USE module_wrf_error
	74	#ifdef DM_PARALLEL
	75	USE module_dm
	76	#endif
	77	! USE read_util_module
	78
	79	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	80	!new for bc
	81	USE module_bc
	82	USE module_big_step_utilities_em
	83	USE module_get_file_names
	84	#ifdef WRF_CHEM
	85	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	86	! for chemistry
	87	USE module_input_chem_data
	88	! USE module_input_chem_bioemiss
	89	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	90	#endif
	91
	92	IMPLICIT NONE
	93	! interface
	94	INTERFACE
	95	! mediation-supplied
	96	SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags)
	97	USE module_domain
	98	TYPE (domain) grid
	99	TYPE (grid_config_rec_type) config_flags
	100	END SUBROUTINE med_read_wrf_chem_bioemiss
	101	SUBROUTINE nup ( parent_grid , nested_grid, in_id, out_id, newly_opened )
	102	USE module_domain
	103	TYPE (domain), POINTER :: parent_grid, nested_grid
	104	INTEGER, INTENT(IN) :: in_id, out_id ! io units
	105	LOGICAL, INTENT(IN) :: newly_opened ! whether to add global metadata
	106	END SUBROUTINE nup
	107
	108	END INTERFACE
	109
	110	TYPE(WRFU_TimeInterval) :: RingInterval
	111
	112	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	113	!new for bc
	114	INTEGER :: ids , ide , jds , jde , kds , kde
	115	INTEGER :: ims , ime , jms , jme , kms , kme
	116	INTEGER :: ips , ipe , jps , jpe , kps , kpe
	117	INTEGER :: its , ite , jts , jte , kts , kte
	118	INTEGER :: ijds , ijde , spec_bdy_width
	119	INTEGER :: i , j , k
	120	INTEGER :: time_loop_max , time_loop
	121	INTEGER :: total_time_sec , file_counter
	122	INTEGER :: julyr , julday , iswater , map_proj
	123	INTEGER :: icnt
	124
	125	REAL :: dt , new_bdy_frq
	126	REAL :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon
	127
	128	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1
	129	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1
	130	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2
	131	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2
	132
	133	CHARACTER(LEN=19) :: start_timestr , current_timestr , end_timestr, timestr
	134	CHARACTER(LEN=19) :: stopTimeStr
	135
	136	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	137
	138	INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
	139
	140	REAL :: time
	141	INTEGER :: rc
	142
	143	INTEGER :: loop , levels_to_process
	144	INTEGER , PARAMETER :: max_sanity_file_loop = 100
	145
	146	TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain, parent_grid , nested_grid
	147	TYPE (domain) :: dummy
	148	TYPE (grid_config_rec_type) :: config_flags
	149	INTEGER :: number_at_same_level
	150	INTEGER :: time_step_begin_restart
	151
	152	INTEGER :: max_dom , domain_id , fid , fido, fidb , idum1 , idum2 , ierr
	153	INTEGER :: status_next_var
	154	INTEGER :: debug_level
	155	LOGICAL :: newly_opened
	156	CHARACTER (LEN=19) :: date_string
	157
	158	#ifdef DM_PARALLEL
	159	INTEGER :: nbytes
	160	INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN
	161	INTEGER :: configbuf( configbuflen )
	162	LOGICAL , EXTERNAL :: wrf_dm_on_monitor
	163	#endif
	164
	165	INTEGER :: idsi, in_id, out_id
	166	INTEGER :: e_sn, e_we, pgr
	167	CHARACTER (LEN=80) :: inpname , outname , bdyname
	168	CHARACTER (LEN=80) :: si_inpname
	169	CHARACTER *19 :: temp19
	170	CHARACTER *24 :: temp24 , temp24b
	171	CHARACTER *132 :: fname
	172	CHARACTER(len=24) :: start_date_hold
	173
	174	CHARACTER (LEN=80) :: message
	175	integer :: ii
	176
	177	#include "version_decl"
	178
	179	! Interface block for routine that passes pointers and needs to know that they
	180	! are receiving pointers.
	181
	182	INTERFACE
	183
	184	SUBROUTINE med_feedback_domain ( parent_grid , nested_grid )
	185	USE module_domain
	186	USE module_configure
	187	TYPE(domain), POINTER :: parent_grid , nested_grid
	188	END SUBROUTINE med_feedback_domain
	189
	190	SUBROUTINE Setup_Timekeeping( parent_grid )
	191	USE module_domain
	192	TYPE(domain), POINTER :: parent_grid
	193	END SUBROUTINE Setup_Timekeeping
	194
	195	END INTERFACE
	196
	197	! Define the name of this program (program_name defined in module_domain)
	198
	199	program_name = "NUP_EM " // TRIM(release_version) // " PREPROCESSOR"
	200
	201	#ifdef DM_PARALLEL
	202	CALL disable_quilting
	203	#endif
	204
	205	! Initialize the modules used by the WRF system. Many of the CALLs made from the
	206	! init_modules routine are NO-OPs. Typical initializations are: the size of a
	207	! REAL, setting the file handles to a pre-use value, defining moisture and
	208	! chemistry indices, etc.
	209
	210	CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called)
	211	CALL WRFU_Initialize( defaultCalendar=WRFU_CAL_GREGORIAN, rc=rc )
	212	CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called)
	213
	214	! Get the NAMELIST data. This is handled in the initial_config routine. All of the
	215	! NAMELIST input variables are assigned to the model_config_rec structure. Below,
	216	! note for parallel processing, only the monitor processor handles the raw Fortran
	217	! I/O, and then broadcasts the info to each of the other nodes.
	218
	219	#ifdef DM_PARALLEL
	220	IF ( wrf_dm_on_monitor() ) THEN
	221	CALL initial_config
	222	ENDIF
	223	CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
	224	CALL wrf_dm_bcast_bytes( configbuf, nbytes )
	225	CALL set_config_as_buffer( configbuf, configbuflen )
	226	CALL wrf_dm_initialize
	227	#else
	228	CALL initial_config
	229	#endif
	230
	231	! And here is an instance of using the information in the NAMELIST.
	232
	233	CALL nl_get_debug_level ( 1, debug_level )
	234	CALL set_wrf_debug_level ( debug_level )
	235
	236	! set the specified boundary to zero so the feedback goes all the way
	237	! to the edge of the coarse domain
	238	CALL nl_set_spec_zone( 1, 0 )
	239
	240	! Allocated and configure the mother domain. Since we are in the nesting down
	241	! mode, we know a) we got a nest, and b) we only got 1 nest.
	242
	243	NULLIFY( null_domain )
	244
	245	!!!! set up the parent grid (for nup_em, this is the grid we do output from)
	246
	247	CALL nl_set_shw( 1, 0 )
	248	CALL nl_set_shw( 2, 0 )
	249	CALL nl_set_i_parent_start( 2, 1 )
	250	CALL nl_set_j_parent_start( 2, 1 )
	251	CALL nl_get_e_we( 2, e_we )
	252	CALL nl_get_e_sn( 2, e_sn )
	253	CALL nl_get_parent_grid_ratio( 2, pgr )
	254
	255	! parent grid must cover the entire nest, which is always dimensioned a factor of 3 + 1
	256	! so add two here temporarily, then remove later after nest is allocated.
	257
	258	e_we = e_we / pgr + 2
	259	e_sn = e_sn / pgr + 2
	260	CALL nl_set_e_we( 1, e_we )
	261	CALL nl_set_e_sn( 1, e_sn )
	262
	263	CALL wrf_message ( program_name )
	264	CALL wrf_debug ( 100 , 'nup_em: calling alloc_and_configure_domain coarse ' )
	265	CALL alloc_and_configure_domain ( domain_id = 1 , &
	266	grid = head_grid , &
	267	parent = null_domain , &
	268	kid = -1 )
	269
	270	parent_grid => head_grid
	271
	272	! Set up time initializations.
	273
	274	CALL Setup_Timekeeping ( parent_grid )
	275
	276	CALL domain_clock_set( head_grid, &
	277	time_step_seconds=model_config_rec%interval_seconds )
	278
	279	CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
	280	CALL set_scalar_indices_from_config ( parent_grid%id , idum1, idum2 )
	281
	282	!!!! set up the fine grid (for nup_em, this is the grid we do input into)
	283
	284	CALL wrf_message ( program_name )
	285	CALL wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain fine ' )
	286	CALL alloc_and_configure_domain ( domain_id = 2 , &
	287	grid = nested_grid , &
	288	parent = parent_grid , &
	289	kid = 1 )
	290
	291	! now that the nest is allocated, pinch off the extra two rows/columns of the parent
	292	! note the IKJ assumption here.
	293	parent_grid%ed31 = parent_grid%ed31 - 2
	294	parent_grid%ed33 = parent_grid%ed33 - 2
	295	CALL nl_set_e_we( 1, e_we-2 )
	296	CALL nl_set_e_sn( 1, e_sn-2 )
	297
	298	write(0,*)'after alloc_and_configure_domain ',associated(nested_grid%intermediate_grid)
	299
	300	CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
	301	CALL set_scalar_indices_from_config ( nested_grid%id , idum1, idum2 )
	302
	303	! Set up time initializations for the fine grid.
	304
	305	CALL Setup_Timekeeping ( nested_grid )
	306	! Adjust the time step on the clock so that it's the same as the history interval
	307
	308	CALL WRFU_AlarmGet( nested_grid%alarms(HISTORY_ALARM), RingInterval=RingInterval )
	309	CALL WRFU_ClockSet( nested_grid%domain_clock, TimeStep=RingInterval, rc=rc )
	310	CALL WRFU_ClockSet( parent_grid%domain_clock, TimeStep=RingInterval, rc=rc )
	311
	312	! Get and store the history interval from the fine grid; use for time loop
	313
	314
	315	! Initialize the I/O for WRF.
	316
	317	CALL init_wrfio
	318
	319	! Some of the configuration values may have been modified from the initial READ
	320	! of the NAMELIST, so we re-broadcast the configuration records.
	321
	322	#ifdef DM_PARALLEL
	323	CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
	324	CALL wrf_dm_bcast_bytes( configbuf, nbytes )
	325	CALL set_config_as_buffer( configbuf, configbuflen )
	326	#endif
	327
	328	! Open the input data (wrfout_d01_xxxxxx) for reading.
	329	in_id = 0
	330	out_id = 0
	331	main_loop : DO WHILE ( domain_get_current_time(nested_grid) .LT. domain_get_stop_time(nested_grid) )
	332
	333	IF( WRFU_AlarmIsRinging( nested_grid%alarms( HISTORY_ALARM ), rc=rc ) ) THEN
	334	CALL domain_clock_get( nested_grid, current_timestr=timestr )
	335	newly_opened = .FALSE.
	336	IF ( in_id.EQ. 0 ) THEN
	337	CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
	338	CALL construct_filename2a ( fname , config_flags%history_outname , nested_grid%id , 2 , timestr )
	339	CALL open_r_dataset ( in_id, TRIM(fname), nested_grid , &
	340	config_flags , 'DATASET=HISTORY' , ierr )
	341	IF ( ierr .NE. 0 ) THEN
	342	WRITE(message,*)'Failed to open ',TRIM(fname),' for reading. '
	343	CALL wrf_message(message)
	344	EXIT main_loop
	345	ENDIF
	346
	347	CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
	348	CALL construct_filename2a ( fname , config_flags%history_outname , parent_grid%id , 2 , timestr )
	349	CALL open_w_dataset ( out_id, TRIM(fname), parent_grid , &
	350	config_flags , output_history, 'DATASET=HISTORY' , ierr )
	351	IF ( ierr .NE. 0 ) THEN
	352	WRITE(message,*)'Failed to open ',TRIM(fname),' for writing. '
	353	CALL wrf_message(message)
	354	EXIT main_loop
	355	ENDIF
	356	newly_opened = .TRUE.
	357	ENDIF
	358
	359	CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
	360	CALL input_history ( in_id, nested_grid , config_flags , ierr )
	361	IF ( ierr .NE. 0 ) THEN
	362	WRITE(message,*)'Unable to read time ',timestr
	363	CALL wrf_message(message)
	364	EXIT main_loop
	365	ENDIF
	366	!
	367	CALL nup ( nested_grid , parent_grid, in_id, out_id, newly_opened )
	368	!
	369	CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
	370	CALL output_history ( out_id, parent_grid , config_flags , ierr )
	371	IF ( ierr .NE. 0 ) THEN
	372	WRITE(message,*)'Unable to write time ',timestr
	373	CALL wrf_message(message)
	374	EXIT main_loop
	375	ENDIF
	376
	377	nested_grid%nframes(0) = nested_grid%nframes(0) + 1
	378	IF ( nested_grid%nframes(0) >= config_flags%frames_per_outfile ) THEN
	379	CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
	380	CALL close_dataset ( in_id , config_flags , "DATASET=HISTORY" )
	381	CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
	382	CALL close_dataset ( out_id , config_flags , "DATASET=HISTORY" )
	383	in_id = 0
	384	out_id = 0
	385	nested_grid%nframes(0) = 0
	386	ENDIF
	387	CALL WRFU_AlarmRingerOff( nested_grid%alarms( HISTORY_ALARM ), rc=rc )
	388	ENDIF
	389	CALL domain_clockadvance( nested_grid )
	390	CALL domain_clockadvance( parent_grid )
	391	ENDDO main_loop
	392	CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
	393	CALL med_shutdown_io ( parent_grid , config_flags )
	394
	395	CALL wrf_debug ( 0 , 'nup_em: SUCCESS COMPLETE NUP_EM INIT' )
	396
	397	! CALL wrf_shutdown
	398
	399	CALL WRFU_Finalize( rc=rc )
	400
	401	END PROGRAM nup_em
	402
	403	SUBROUTINE nup ( nested_grid, parent_grid , in_id, out_id, newly_opened )
	404	USE module_domain
	405	USE module_io_domain
	406	USE module_utility
	407	USE module_timing
	408	USE module_wrf_error
	409	!
	410	IMPLICIT NONE
	411
	412	! Args
	413	TYPE(domain), POINTER :: parent_grid, nested_grid
	414	INTEGER, INTENT(IN) :: in_id, out_id ! io descriptors
	415	LOGICAL, INTENT(IN) :: newly_opened ! whether to add global metadata
	416	! Local
	417	INTEGER :: julyr , julday , iswater , map_proj
	418	INTEGER :: icnt, ierr
	419	REAL :: dt , new_bdy_frq
	420	REAL :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon
	421	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1
	422	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1
	423	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2
	424	REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2
	425	INTEGER :: ids , ide , jds , jde , kds , kde
	426	INTEGER :: ims , ime , jms , jme , kms , kme
	427	INTEGER :: ips , ipe , jps , jpe , kps , kpe
	428	INTEGER :: its , ite , jts , jte , kts , kte
	429
	430	INTERFACE
	431	SUBROUTINE med_feedback_domain ( parent_grid , nested_grid )
	432	USE module_domain
	433	USE module_configure
	434	TYPE(domain), POINTER :: parent_grid , nested_grid
	435	END SUBROUTINE med_feedback_domain
	436	SUBROUTINE med_interp_domain ( parent_grid , nested_grid )
	437	USE module_domain
	438	USE module_configure
	439	TYPE(domain), POINTER :: parent_grid , nested_grid
	440	END SUBROUTINE med_interp_domain
	441	END INTERFACE
	442
	443	IF ( newly_opened ) THEN
	444	CALL wrf_get_dom_ti_integer ( in_id , 'MAP_PROJ' , map_proj , 1 , icnt , ierr )
	445	CALL wrf_get_dom_ti_real ( in_id , 'DX' , dx , 1 , icnt , ierr )
	446	CALL wrf_get_dom_ti_real ( in_id , 'DY' , dy , 1 , icnt , ierr )
	447	CALL wrf_get_dom_ti_real ( in_id , 'CEN_LAT' , cen_lat , 1 , icnt , ierr )
	448	CALL wrf_get_dom_ti_real ( in_id , 'CEN_LON' , cen_lon , 1 , icnt , ierr )
	449	CALL wrf_get_dom_ti_real ( in_id , 'TRUELAT1' , truelat1 , 1 , icnt , ierr )
	450	CALL wrf_get_dom_ti_real ( in_id , 'TRUELAT2' , truelat2 , 1 , icnt , ierr )
	451	CALL wrf_get_dom_ti_real ( in_id , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , icnt , ierr )
	452	CALL wrf_get_dom_ti_real ( in_id , 'STAND_LON' , stand_lon , 1 , icnt , ierr )
	453	! CALL wrf_get_dom_ti_real ( in_id , 'GMT' , gmt , 1 , icnt , ierr )
	454	! CALL wrf_get_dom_ti_integer ( in_id , 'JULYR' , julyr , 1 , icnt , ierr )
	455	! CALL wrf_get_dom_ti_integer ( in_id , 'JULDAY' , julday , 1 , icnt , ierr )
	456	CALL wrf_get_dom_ti_integer ( in_id , 'ISWATER' , iswater , 1 , icnt , ierr )
	457	ENDIF
	458
	459	parent_grid%fnm = nested_grid%fnm
	460	parent_grid%fnp = nested_grid%fnp
	461	parent_grid%rdnw = nested_grid%rdnw
	462	parent_grid%rdn = nested_grid%rdn
	463	parent_grid%dnw = nested_grid%dnw
	464	parent_grid%dn = nested_grid%dn
	465	parent_grid%znu = nested_grid%znu
	466	parent_grid%znw = nested_grid%znw
	467
	468	parent_grid%zs = nested_grid%zs
	469	parent_grid%dzs = nested_grid%dzs
	470
	471	parent_grid%p_top = nested_grid%p_top
	472	parent_grid%rdx = nested_grid%rdx * 3.
	473	parent_grid%rdy = nested_grid%rdy * 3.
	474	parent_grid%resm = nested_grid%resm
	475	parent_grid%zetatop = nested_grid%zetatop
	476	parent_grid%cf1 = nested_grid%cf1
	477	parent_grid%cf2 = nested_grid%cf2
	478	parent_grid%cf3 = nested_grid%cf3
	479
	480	parent_grid%cfn = nested_grid%cfn
	481	parent_grid%cfn1 = nested_grid%cfn1
	482
	483	#ifdef WRF_CHEM
	484	parent_grid%chem_opt = nested_grid%chem_opt
	485	parent_grid%chem_in_opt = nested_grid%chem_in_opt
	486	#endif
	487
	488	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	489
	490	! Various sizes that we need to be concerned about.
	491
	492	ids = parent_grid%sd31
	493	ide = parent_grid%ed31
	494	kds = parent_grid%sd32
	495	kde = parent_grid%ed32
	496	jds = parent_grid%sd33
	497	jde = parent_grid%ed33
	498
	499	ims = parent_grid%sm31
	500	ime = parent_grid%em31
	501	kms = parent_grid%sm32
	502	kme = parent_grid%em32
	503	jms = parent_grid%sm33
	504	jme = parent_grid%em33
	505
	506	ips = parent_grid%sp31
	507	ipe = parent_grid%ep31
	508	kps = parent_grid%sp32
	509	kpe = parent_grid%ep32
	510	jps = parent_grid%sp33
	511	jpe = parent_grid%ep33
	512
	513	nested_grid%imask_nostag = 1
	514	nested_grid%imask_xstag = 1
	515	nested_grid%imask_ystag = 1
	516	nested_grid%imask_xystag = 1
	517
	518	! Interpolate from nested_grid back onto parent_grid
	519	CALL med_feedback_domain ( parent_grid , nested_grid )
	520
	521	parent_grid%ht_int = parent_grid%ht
	522
	523	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	524
	525	#if 0
	526	CALL construct_filename2( si_inpname , 'wrf_real_input_em' , parent_grid%id , 2 , start_date_char )
	527	CALL wrf_debug ( 100 , 'med_sidata_input: calling open_r_dataset for ' // TRIM(si_inpname) )
	528	CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
	529	CALL open_r_dataset ( idsi, TRIM(si_inpname) , parent_grid , config_flags , "DATASET=INPUT", ierr )
	530	IF ( ierr .NE. 0 ) THEN
	531	CALL wrf_error_fatal( 'real: error opening wrf_real_input_em for reading: ' // TRIM (si_inpname) )
	532	END IF
	533
	534	! Input data.
	535
	536	CALL wrf_debug ( 100 , 'nup_em: calling input_aux_model_input2' )
	537	CALL input_aux_model_input2 ( idsi , parent_grid , config_flags , ierr )
	538	parent_grid%ht_input = parent_grid%ht
	539
	540	! Close this fine grid static input file.
	541
	542	CALL wrf_debug ( 100 , 'nup_em: closing fine grid static input' )
	543	CALL close_dataset ( idsi , config_flags , "DATASET=INPUT" )
	544
	545	! We need a parent grid landuse in the interpolation. So we need to generate
	546	! that field now.
	547
	548	IF ( ( parent_grid%ivgtyp(ips,jps) .GT. 0 ) .AND. &
	549	( parent_grid%isltyp(ips,jps) .GT. 0 ) ) THEN
	550	DO j = jps, MIN(jde-1,jpe)
	551	DO i = ips, MIN(ide-1,ipe)
	552	parent_grid% vegcat(i,j) = parent_grid%ivgtyp(i,j)
	553	parent_grid%soilcat(i,j) = parent_grid%isltyp(i,j)
	554	END DO
	555	END DO
	556
	557	ELSE IF ( ( parent_grid% vegcat(ips,jps) .GT. 0.5 ) .AND. &
	558	( parent_grid%soilcat(ips,jps) .GT. 0.5 ) ) THEN
	559	DO j = jps, MIN(jde-1,jpe)
	560	DO i = ips, MIN(ide-1,ipe)
	561	parent_grid%ivgtyp(i,j) = NINT(parent_grid% vegcat(i,j))
	562	parent_grid%isltyp(i,j) = NINT(parent_grid%soilcat(i,j))
	563	END DO
	564	END DO
	565
	566	ELSE
	567	num_veg_cat = SIZE ( parent_grid%landusef , DIM=2 )
	568	num_soil_top_cat = SIZE ( parent_grid%soilctop , DIM=2 )
	569	num_soil_bot_cat = SIZE ( parent_grid%soilcbot , DIM=2 )
	570
	571	CALL land_percentages ( parent_grid%xland , &
	572	parent_grid%landusef , parent_grid%soilctop , parent_grid%soilcbot , &
	573	parent_grid%isltyp , parent_grid%ivgtyp , &
	574	num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
	575	ids , ide , jds , jde , kds , kde , &
	576	ims , ime , jms , jme , kms , kme , &
	577	ips , ipe , jps , jpe , kps , kpe , &
	578	model_config_rec%iswater(parent_grid%id) )
	579
	580	END IF
	581
	582	DO j = jps, MIN(jde-1,jpe)
	583	DO i = ips, MIN(ide-1,ipe)
	584	parent_grid%lu_index(i,j) = parent_grid%ivgtyp(i,j)
	585	END DO
	586	END DO
	587
	588	CALL check_consistency ( parent_grid%ivgtyp , parent_grid%isltyp , parent_grid%landmask , &
	589	ids , ide , jds , jde , kds , kde , &
	590	ims , ime , jms , jme , kms , kme , &
	591	ips , ipe , jps , jpe , kps , kpe , &
	592	model_config_rec%iswater(parent_grid%id) )
	593
	594	CALL check_consistency2( parent_grid%ivgtyp , parent_grid%isltyp , parent_grid%landmask , &
	595	parent_grid%tmn , parent_grid%tsk , parent_grid%sst , parent_grid%xland , &
	596	parent_grid%tslb , parent_grid%smois , parent_grid%sh2o , &
	597	config_flags%num_soil_layers , parent_grid%id , &
	598	ids , ide , jds , jde , kds , kde , &
	599	ims , ime , jms , jme , kms , kme , &
	600	ips , ipe , jps , jpe , kps , kpe , &
	601	model_config_rec%iswater(parent_grid%id) )
	602
	603
	604	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	605
	606	! We have 2 terrain elevations. One is from input and the other is from the
	607	! the horizontal interpolation.
	608
	609	parent_grid%ht_fine = parent_grid%ht_input
	610	parent_grid%ht = parent_grid%ht_int
	611
	612	! We have both the interpolated fields and the higher-resolution static fields. From these
	613	! the rebalancing is now done. Note also that the field parent_grid%ht is now from the
	614	! fine grid input file (after this call is completed).
	615
	616	CALL rebalance_driver ( parent_grid )
	617
	618	! Different things happen during the different time loops:
	619	! first loop - write wrfinput file, close data set, copy files to holder arrays
	620	! middle loops - diff 3d/2d arrays, compute and output bc
	621	! last loop - diff 3d/2d arrays, compute and output bc, write wrfbdy file, close wrfbdy file
	622
	623	! Set the time info.
	624
	625	print *,'current_date = ',current_date
	626	CALL domain_clock_set( parent_grid, &
	627	current_timestr=current_date(1:19) )
	628	!
	629	! SEP Put in chemistry data
	630	!
	631	#ifdef WRF_CHEM
	632	IF( parent_grid%chem_opt .NE. 0 ) then
	633	IF( parent_grid%chem_in_opt .EQ. 0 ) then
	634	! Read the chemistry data from a previous wrf forecast (wrfout file)
	635	! Generate chemistry data from a idealized vertical profile
	636	message = 'STARTING WITH BACKGROUND CHEMISTRY '
	637	CALL wrf_message ( message )
	638
	639	CALL input_chem_profile ( parent_grid )
	640
	641	message = 'READING BEIS3.11 EMISSIONS DATA'
	642	CALL wrf_message ( message )
	643
	644	CALL med_read_wrf_chem_bioemiss ( parent_grid , config_flags)
	645	ELSE
	646	message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION'
	647	CALL wrf_message ( message )
	648	ENDIF
	649	ENDIF
	650	#endif
	651
	652	#endif
	653
	654	! Output the first time period of the data.
	655
	656	IF ( newly_opened ) THEN
	657	CALL wrf_put_dom_ti_integer ( out_id , 'MAP_PROJ' , map_proj , 1 , ierr )
	658	! CALL wrf_put_dom_ti_real ( out_id , 'DX' , dx , 1 , ierr )
	659	! CALL wrf_put_dom_ti_real ( out_id , 'DY' , dy , 1 , ierr )
	660	CALL wrf_put_dom_ti_real ( out_id , 'CEN_LAT' , cen_lat , 1 , ierr )
	661	CALL wrf_put_dom_ti_real ( out_id , 'CEN_LON' , cen_lon , 1 , ierr )
	662	CALL wrf_put_dom_ti_real ( out_id , 'TRUELAT1' , truelat1 , 1 , ierr )
	663	CALL wrf_put_dom_ti_real ( out_id , 'TRUELAT2' , truelat2 , 1 , ierr )
	664	CALL wrf_put_dom_ti_real ( out_id , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , ierr )
	665	CALL wrf_put_dom_ti_real ( out_id , 'STAND_LON' , stand_lon , 1 , ierr )
	666	CALL wrf_put_dom_ti_integer ( out_id , 'ISWATER' , iswater , 1 , ierr )
	667
	668	CALL wrf_put_dom_ti_real ( out_id , 'GMT' , gmt , 1 , ierr )
	669	CALL wrf_put_dom_ti_integer ( out_id , 'JULYR' , julyr , 1 , ierr )
	670	CALL wrf_put_dom_ti_integer ( out_id , 'JULDAY' , julday , 1 , ierr )
	671	ENDIF
	672
	673	END SUBROUTINE nup
	674
	675	SUBROUTINE land_percentages ( xland , &
	676	landuse_frac , soil_top_cat , soil_bot_cat , &
	677	isltyp , ivgtyp , &
	678	num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
	679	ids , ide , jds , jde , kds , kde , &
	680	ims , ime , jms , jme , kms , kme , &
	681	its , ite , jts , jte , kts , kte , &
	682	iswater )
	683	USE module_soil_pre
	684
	685	IMPLICIT NONE
	686
	687	INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
	688	ims , ime , jms , jme , kms , kme , &
	689	its , ite , jts , jte , kts , kte , &
	690	iswater
	691
	692	INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
	693	REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac
	694	REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat
	695	REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat
	696	INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
	697	REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: xland
	698
	699	CALL process_percent_cat_new ( xland , &
	700	landuse_frac , soil_top_cat , soil_bot_cat , &
	701	isltyp , ivgtyp , &
	702	num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
	703	ids , ide , jds , jde , kds , kde , &
	704	ims , ime , jms , jme , kms , kme , &
	705	its , ite , jts , jte , kts , kte , &
	706	iswater )
	707
	708	END SUBROUTINE land_percentages
	709
	710	SUBROUTINE check_consistency ( ivgtyp , isltyp , landmask , &
	711	ids , ide , jds , jde , kds , kde , &
	712	ims , ime , jms , jme , kms , kme , &
	713	its , ite , jts , jte , kts , kte , &
	714	iswater )
	715
	716	IMPLICIT NONE
	717
	718	INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
	719	ims , ime , jms , jme , kms , kme , &
	720	its , ite , jts , jte , kts , kte , &
	721	iswater
	722	INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: isltyp , ivgtyp
	723	REAL , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: landmask
	724
	725	LOGICAL :: oops
	726	INTEGER :: oops_count , i , j
	727
	728	oops = .FALSE.
	729	oops_count = 0
	730
	731	DO j = jts, MIN(jde-1,jte)
	732	DO i = its, MIN(ide-1,ite)
	733	IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater ) ) .OR. &
	734	( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater ) ) ) THEN
	735	print *,'mismatch in landmask and veg type'
	736	print *,'i,j=',i,j, ' landmask =',NINT(landmask(i,j)),' ivgtyp=',ivgtyp(i,j)
	737	oops = .TRUE.
	738	oops_count = oops_count + 1
	739	landmask(i,j) = 0
	740	ivgtyp(i,j)=16
	741	isltyp(i,j)=14
	742	END IF
	743	END DO
	744	END DO
	745
	746	IF ( oops ) THEN
	747	CALL wrf_debug( 0, 'mismatch in check_consistency, turned to water points, be careful' )
	748	END IF
	749
	750	END SUBROUTINE check_consistency
	751
	752	SUBROUTINE check_consistency2( ivgtyp , isltyp , landmask , &
	753	tmn , tsk , sst , xland , &
	754	tslb , smois , sh2o , &
	755	num_soil_layers , id , &
	756	ids , ide , jds , jde , kds , kde , &
	757	ims , ime , jms , jme , kms , kme , &
	758	its , ite , jts , jte , kts , kte , &
	759	iswater )
	760
	761	USE module_configure
	762	USE module_optional_input
	763
	764	INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
	765	ims , ime , jms , jme , kms , kme , &
	766	its , ite , jts , jte , kts , kte
	767	INTEGER , INTENT(IN) :: num_soil_layers , id
	768
	769	INTEGER , DIMENSION(ims:ime,jms:jme) :: ivgtyp , isltyp
	770	REAL , DIMENSION(ims:ime,jms:jme) :: landmask , tmn , tsk , sst , xland
	771	REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) :: tslb , smois , sh2o
	772
	773	INTEGER :: oops1 , oops2
	774	INTEGER :: i , j , k
	775
	776	fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(id) )
	777
	778	CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME )
	779	DO j = jts, MIN(jde-1,jte)
	780	DO i = its, MIN(ide-1,ite)
	781	IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
	782	tmn(i,j) = sst(i,j)
	783	tsk(i,j) = sst(i,j)
	784	ELSE IF ( landmask(i,j) .LT. 0.5 ) THEN
	785	tmn(i,j) = tsk(i,j)
	786	END IF
	787	END DO
	788	END DO
	789	END SELECT fix_tsk_tmn
	790
	791	! Is the TSK reasonable?
	792
	793	DO j = jts, MIN(jde-1,jte)
	794	DO i = its, MIN(ide-1,ite)
	795	IF ( tsk(i,j) .LT. 170 .or. tsk(i,j) .GT. 400. ) THEN
	796	print *,'error in the TSK'
	797	print *,'i,j=',i,j
	798	print *,'landmask=',landmask(i,j)
	799	print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
	800	if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
	801	tsk(i,j)=tmn(i,j)
	802	else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
	803	tsk(i,j)=sst(i,j)
	804	else
	805	CALL wrf_error_fatal ( 'TSK unreasonable' )
	806	end if
	807	END IF
	808	END DO
	809	END DO
	810
	811	! Is the TMN reasonable?
	812
	813	DO j = jts, MIN(jde-1,jte)
	814	DO i = its, MIN(ide-1,ite)
	815	IF ( ( ( tmn(i,j) .LT. 170. ) .OR. ( tmn(i,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
	816	print *,'error in the TMN'
	817	print *,'i,j=',i,j
	818	print *,'landmask=',landmask(i,j)
	819	print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
	820	if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
	821	tmn(i,j)=tsk(i,j)
	822	else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
	823	tmn(i,j)=sst(i,j)
	824	else
	825	CALL wrf_error_fatal ( 'TMN unreasonable' )
	826	endif
	827	END IF
	828	END DO
	829	END DO
	830
	831	! Is the TSLB reasonable?
	832
	833	DO j = jts, MIN(jde-1,jte)
	834	DO i = its, MIN(ide-1,ite)
	835	IF ( ( ( tslb(i,1,j) .LT. 170. ) .OR. ( tslb(i,1,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
	836	print *,'error in the TSLB'
	837	print *,'i,j=',i,j
	838	print *,'landmask=',landmask(i,j)
	839	print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
	840	print *,'tslb = ',tslb(i,:,j)
	841	print *,'old smois = ',smois(i,:,j)
	842	DO l = 1 , num_soil_layers
	843	sh2o(i,l,j) = 0.0
	844	END DO
	845	DO l = 1 , num_soil_layers
	846	smois(i,l,j) = 0.3
	847	END DO
	848	if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
	849	DO l = 1 , num_soil_layers
	850	tslb(i,l,j)=tsk(i,j)
	851	END DO
	852	else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
	853	DO l = 1 , num_soil_layers
	854	tslb(i,l,j)=sst(i,j)
	855	END DO
	856	else if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
	857	DO l = 1 , num_soil_layers
	858	tslb(i,l,j)=tmn(i,j)
	859	END DO
	860	else
	861	CALL wrf_error_fatal ( 'TSLB unreasonable' )
	862	endif
	863	END IF
	864	END DO
	865	END DO
	866
	867	! Let us make sure (again) that the landmask and the veg/soil categories match.
	868
	869	oops1=0
	870	oops2=0
	871	DO j = jts, MIN(jde-1,jte)
	872	DO i = its, MIN(ide-1,ite)
	873	IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater .OR. isltyp(i,j) .NE. 14 ) ) .OR. &
	874	( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater .OR. isltyp(i,j) .EQ. 14 ) ) ) THEN
	875	IF ( tslb(i,1,j) .GT. 1. ) THEN
	876	oops1=oops1+1
	877	ivgtyp(i,j) = 5
	878	isltyp(i,j) = 8
	879	landmask(i,j) = 1
	880	xland(i,j) = 1
	881	ELSE IF ( sst(i,j) .GT. 1. ) THEN
	882	oops2=oops2+1
	883	ivgtyp(i,j) = iswater
	884	isltyp(i,j) = 14
	885	landmask(i,j) = 0
	886	xland(i,j) = 2
	887	ELSE
	888	print *,'the landmask and soil/veg cats do not match'
	889	print *,'i,j=',i,j
	890	print *,'landmask=',landmask(i,j)
	891	print *,'ivgtyp=',ivgtyp(i,j)
	892	print *,'isltyp=',isltyp(i,j)
	893	print *,'iswater=', iswater
	894	print *,'tslb=',tslb(i,:,j)
	895	print *,'sst=',sst(i,j)
	896	CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' )
	897	END IF
	898	END IF
	899	END DO
	900	END DO
	901	if (oops1.gt.0) then
	902	print *,'points artificially set to land : ',oops1
	903	endif
	904	if(oops2.gt.0) then
	905	print *,'points artificially set to water: ',oops2
	906	endif
	907
	908	END SUBROUTINE check_consistency2

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

Download in other formats:

Original Format