Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

nup_em.F @ 3567

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

Line
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