Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

nup_em.F @ 1393

Last change on this file since 1393 was 1, checked in by lfita, 10 years ago

-- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

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

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

Download in other formats:

Original Format