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