| blob | df5c748e27efc3105953b87ecd5755e2d56316dd |
1 !WRF:DRIVER_LAYER:MAIN
2 !
4 PROGRAM ndown_em
6 USE module_machine
7 USE module_domain, ONLY : domain, head_grid, alloc_and_configure_domain, &
8 domain_clock_set, domain_clock_get, get_ijk_from_grid
9 USE module_domain_type, ONLY : program_name
10 USE module_initialize_real, ONLY : wrfu_initialize, rebalance_driver
11 USE module_integrate
12 USE module_driver_constants
13 USE module_configure, ONLY : grid_config_rec_type, model_config_rec
14 USE module_io_domain
15 USE module_utility
16 USE module_check_a_mundo
18 USE module_timing
19 USE module_wrf_error
20 #ifdef DM_PARALLEL
21 USE module_dm
22 #endif
24 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
25 !new for bc
26 USE module_bc
27 USE module_big_step_utilities_em
28 USE module_get_file_names
29 #ifdef WRF_CHEM
30 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
31 ! for chemistry
32 USE module_input_chem_data
33 ! USE module_input_chem_bioemiss
34 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
35 #endif
37 IMPLICIT NONE
38 ! interface
39 INTERFACE
40 ! mediation-supplied
41 SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags)
42 USE module_domain
43 TYPE (domain) grid
44 TYPE (grid_config_rec_type) config_flags
45 END SUBROUTINE med_read_wrf_chem_bioemiss
47 SUBROUTINE init_domain_constants_em_ptr ( parent , nest )
48 USE module_domain
49 USE module_configure
50 TYPE(domain), POINTER :: parent , nest
51 END SUBROUTINE init_domain_constants_em_ptr
53 SUBROUTINE vertical_interp (nested_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c)
54 USE module_domain
55 USE module_configure
56 TYPE(domain), POINTER :: nested_grid
57 INTEGER , INTENT (IN) :: k_dim_c
58 REAL , INTENT (IN) :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c
59 REAL , DIMENSION(k_dim_c) , INTENT (IN) :: znw_c,znu_c
60 END SUBROUTINE vertical_interp
63 END INTERFACE
64 INTEGER :: ids , ide , jds , jde , kds , kde
65 INTEGER :: ims , ime , jms , jme , kms , kme
66 INTEGER :: ips , ipe , jps , jpe , kps , kpe
67 INTEGER :: its , ite , jts , jte , kts , kte
68 INTEGER :: nids, nide, njds, njde, nkds, nkde, &
69 nims, nime, njms, njme, nkms, nkme, &
70 nips, nipe, njps, njpe, nkps, nkpe
71 INTEGER :: spec_bdy_width
72 INTEGER :: i , j , k , nvchem
73 INTEGER :: time_loop_max , time_loop
74 INTEGER :: total_time_sec , file_counter
75 INTEGER :: julyr , julday , iswater , map_proj
76 INTEGER :: icnt
78 REAL :: dt , new_bdy_frq
79 REAL :: gmt , cen_lat , cen_lon , dx , dy , truelat1 , truelat2 , moad_cen_lat , stand_lon
81 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp1 , vbdy3dtemp1 , tbdy3dtemp1 , pbdy3dtemp1 , qbdy3dtemp1
82 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp1
83 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2
84 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: mbdy2dtemp2
85 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: cbdy3dtemp1 , cbdy3dtemp2
86 REAL , DIMENSION(:,:,:,:) , ALLOCATABLE :: cbdy3dtemp0
88 CHARACTER(LEN=19) :: start_date_char , current_date_char , end_date_char
89 CHARACTER(LEN=19) :: stopTimeStr
91 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
93 INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
95 REAL :: time
96 INTEGER :: rc
98 INTEGER :: loop , levels_to_process
99 INTEGER , PARAMETER :: max_sanity_file_loop = 100
101 TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain, parent_grid , nested_grid
102 TYPE (domain) :: dummy
103 TYPE (grid_config_rec_type) :: config_flags
104 INTEGER :: number_at_same_level
105 INTEGER :: time_step_begin_restart
107 INTEGER :: max_dom , domain_id , fid , fido, fidb , oid , idum1 , idum2 , ierr
108 INTEGER :: status_next_var
109 INTEGER :: debug_level
110 LOGICAL :: input_from_file , need_new_file
111 CHARACTER (LEN=19) :: date_string
113 #ifdef DM_PARALLEL
114 INTEGER :: nbytes
115 INTEGER, PARAMETER :: configbuflen = 4* CONFIG_BUF_LEN
116 INTEGER :: configbuf( configbuflen )
117 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
118 #endif
120 INTEGER :: idsi
121 CHARACTER (LEN=80) :: inpname , outname , bdyname
122 CHARACTER (LEN=80) :: si_inpname
123 character *19 :: temp19
124 character *24 :: temp24 , temp24b
125 character(len=24) :: start_date_hold
127 CHARACTER (LEN=256) :: message
128 integer :: ii
130 #include "version_decl"
132 !!!!!!!!!!!!!!!!!!!!! mousta
133 integer :: n_ref_m,k_dim_c,k_dim_n
134 real :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c
135 REAL , DIMENSION(:) , ALLOCATABLE :: znw_c,znu_c
136 !!!!!!!!!!!!!!!!!!!!!!!!!!11
138 ! Interface block for routine that passes pointers and needs to know that they
139 ! are receiving pointers.
141 INTERFACE
143 SUBROUTINE med_interp_domain ( parent_grid , nested_grid )
144 USE module_domain
145 USE module_configure
146 TYPE(domain), POINTER :: parent_grid , nested_grid
147 END SUBROUTINE med_interp_domain
149 SUBROUTINE Setup_Timekeeping( parent_grid )
150 USE module_domain
151 TYPE(domain), POINTER :: parent_grid
152 END SUBROUTINE Setup_Timekeeping
154 SUBROUTINE vert_cor(parent_grid,znw_c,k_dim_c)
155 USE module_domain
156 TYPE(domain), POINTER :: parent_grid
157 integer , intent(in) :: k_dim_c
158 real , dimension(k_dim_c), INTENT(IN) :: znw_c
159 END SUBROUTINE vert_cor
160 END INTERFACE
162 ! Define the name of this program (program_name defined in module_domain)
164 program_name = "NDOWN_EM " // TRIM(release_version) // " PREPROCESSOR"
166 #ifdef DM_PARALLEL
167 CALL disable_quilting
168 #endif
170 ! Initialize the modules used by the WRF system. Many of the CALLs made from the
171 ! init_modules routine are NO-OPs. Typical initializations are: the size of a
172 ! REAL, setting the file handles to a pre-use value, defining moisture and
173 ! chemistry indices, etc.
175 CALL init_modules(1) ! Phase 1 returns after MPI_INIT() (if it is called)
176 #ifdef NO_LEAP_CALENDAR
177 CALL WRFU_Initialize( defaultCalKind=WRFU_CAL_NOLEAP, rc=rc )
178 #else
179 CALL WRFU_Initialize( defaultCalKind=WRFU_CAL_GREGORIAN, rc=rc )
180 #endif
181 CALL init_modules(2) ! Phase 2 resumes after MPI_INIT() (if it is called)
183 ! Get the NAMELIST data. This is handled in the initial_config routine. All of the
184 ! NAMELIST input variables are assigned to the model_config_rec structure. Below,
185 ! note for parallel processing, only the monitor processor handles the raw Fortran
186 ! I/O, and then broadcasts the info to each of the other nodes.
188 #ifdef DM_PARALLEL
189 IF ( wrf_dm_on_monitor() ) THEN
190 CALL initial_config
191 ENDIF
192 CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
193 CALL wrf_dm_bcast_bytes( configbuf, nbytes )
194 CALL set_config_as_buffer( configbuf, configbuflen )
195 CALL wrf_dm_initialize
196 #else
197 CALL initial_config
198 #endif
200 CALL check_nml_consistency
201 CALL set_physics_rconfigs
203 ! If we are running ndown, and that is WHERE we are now, make sure that we account
204 ! for folks forgetting to say that the aux_input2 stream is in place.
206 IF ( model_config_rec%io_form_auxinput2 .EQ. 0 ) THEN
207 CALL wrf_error_fatal( 'ndown: Please set io_form_auxinput2 in the time_control namelist record (probably to 2).')
208 END IF
210 !!!!!!!!!!!!!!! mousta
211 n_ref_m = model_config_rec % vert_refine_fact
212 k_dim_c = model_config_rec % e_vert(1)
213 k_dim_n = k_dim_c
214 if (n_ref_m .ge. 2) k_dim_n = (k_dim_c - 1) * n_ref_m + 1
215 model_config_rec % e_vert(1) = k_dim_n
216 model_config_rec % e_vert(2) = k_dim_n
217 ALLOCATE(znw_c(k_dim_c))
218 ALLOCATE(znu_c(k_dim_c))
219 WRITE ( message , FMT = '(A,3I5)' ) 'KDIM_C', k_dim_c , model_config_rec % e_vert(1) , model_config_rec % e_vert(2)
220 CALL wrf_debug ( 99,message )
221 !!!!!!!!!!!!!!! mousta
223 ! And here is an instance of using the information in the NAMELIST.
225 CALL nl_get_debug_level ( 1, debug_level )
226 CALL set_wrf_debug_level ( debug_level )
228 ! Allocated and configure the mother domain. Since we are in the nesting down
229 ! mode, we know a) we got a nest, and b) we only got 1 nest.
231 NULLIFY( null_domain )
233 CALL wrf_message ( program_name )
234 CALL wrf_debug ( 100 , 'ndown_em: calling alloc_and_configure_domain coarse ' )
235 CALL alloc_and_configure_domain ( domain_id = 1 , &
236 grid = head_grid , &
237 parent = null_domain , &
238 kid = -1 )
240 parent_grid => head_grid
242 ! Set up time initializations.
244 CALL Setup_Timekeeping ( parent_grid )
246 CALL domain_clock_set( head_grid, &
247 time_step_seconds=model_config_rec%interval_seconds )
248 CALL wrf_debug ( 100 , 'ndown_em: calling model_to_grid_config_rec ' )
249 CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
250 CALL wrf_debug ( 100 , 'ndown_em: calling set_scalar_indices_from_config ' )
251 CALL set_scalar_indices_from_config ( parent_grid%id , idum1, idum2 )
253 ! Initialize the I/O for WRF.
255 CALL wrf_debug ( 100 , 'ndown_em: calling init_wrfio' )
256 CALL init_wrfio
258 ! Some of the configuration values may have been modified from the initial READ
259 ! of the NAMELIST, so we re-broadcast the configuration records.
261 #ifdef DM_PARALLEL
262 CALL get_config_as_buffer( configbuf, configbuflen, nbytes )
263 CALL wrf_dm_bcast_bytes( configbuf, nbytes )
264 CALL set_config_as_buffer( configbuf, configbuflen )
265 #endif
267 ! We need to current and starting dates for the output files. The times need to be incremented
268 ! so that the lateral BC files are not overwritten.
270 #ifdef PLANET
271 WRITE ( start_date_char , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
272 model_config_rec%start_year (parent_grid%id) , &
273 model_config_rec%start_day (parent_grid%id) , &
274 model_config_rec%start_hour (parent_grid%id) , &
275 model_config_rec%start_minute(parent_grid%id) , &
276 model_config_rec%start_second(parent_grid%id)
278 WRITE ( end_date_char , FMT = '(I4.4,"-",I5.5,"_",I2.2,":",I2.2,":",I2.2)' ) &
279 model_config_rec% end_year (parent_grid%id) , &
280 model_config_rec% end_day (parent_grid%id) , &
281 model_config_rec% end_hour (parent_grid%id) , &
282 model_config_rec% end_minute(parent_grid%id) , &
283 model_config_rec% end_second(parent_grid%id)
284 #else
285 WRITE ( start_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
286 model_config_rec%start_year (parent_grid%id) , &
287 model_config_rec%start_month (parent_grid%id) , &
288 model_config_rec%start_day (parent_grid%id) , &
289 model_config_rec%start_hour (parent_grid%id) , &
290 model_config_rec%start_minute(parent_grid%id) , &
291 model_config_rec%start_second(parent_grid%id)
293 WRITE ( end_date_char , FMT = '(I4.4,"-",I2.2,"-",I2.2,"_",I2.2,":",I2.2,":",I2.2)' ) &
294 model_config_rec% end_year (parent_grid%id) , &
295 model_config_rec% end_month (parent_grid%id) , &
296 model_config_rec% end_day (parent_grid%id) , &
297 model_config_rec% end_hour (parent_grid%id) , &
298 model_config_rec% end_minute(parent_grid%id) , &
299 model_config_rec% end_second(parent_grid%id)
300 #endif
302 ! Override stop time with value computed above.
303 CALL domain_clock_set( parent_grid, stop_timestr=end_date_char )
305 CALL geth_idts ( end_date_char , start_date_char , total_time_sec )
307 new_bdy_frq = model_config_rec%interval_seconds
308 time_loop_max = total_time_sec / model_config_rec%interval_seconds + 1
310 start_date = start_date_char // '.0000'
311 current_date = start_date_char // '.0000'
312 start_date_hold = start_date_char // '.0000'
313 current_date_char = start_date_char
315 ! Get a list of available file names to try. This fills up the eligible_file_name
316 ! array with number_of_eligible_files entries. This routine issues a nonstandard
317 ! call (system).
319 file_counter = 1
320 need_new_file = .FALSE.
321 CALL unix_ls ( 'wrfout' , parent_grid%id )
323 ! Open the input data (wrfout_d01_xxxxxx) for reading.
325 CALL wrf_debug ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) )
326 CALL open_r_dataset ( fid, TRIM(eligible_file_name(file_counter)) , head_grid , config_flags , "DATASET=AUXINPUT1", ierr )
327 IF ( ierr .NE. 0 ) THEN
328 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(eligible_file_name(file_counter)), &
329 ' for reading ierr=',ierr
330 CALL WRF_ERROR_FATAL ( wrf_err_message )
331 ENDIF
333 ! We know how many time periods to process, so we begin.
335 big_time_loop_thingy : DO time_loop = 1 , time_loop_max
337 ! Which date are we currently soliciting?
339 CALL geth_newdate ( date_string , start_date_char , ( time_loop - 1 ) * NINT ( new_bdy_frq) )
340 WRITE ( message , FMT = '(A,I5," ",A,A)' ) '-------->>> Processing data: loop=',time_loop,' date/time = ',date_string
341 CALL wrf_debug ( 99,message )
342 current_date_char = date_string
343 current_date = date_string // '.0000'
344 start_date = date_string // '.0000'
345 WRITE ( message , FMT = '(A,I5," ",A,A)' ) 'loopmax = ', time_loop_max, ' ending date = ',end_date_char
346 CALL wrf_debug ( 99,message )
347 CALL domain_clock_set( parent_grid, &
348 current_timestr=current_date(1:19) )
350 ! Which times are in this file, and more importantly, are any of them the
351 ! ones that we want? We need to loop over times in each files, loop
352 ! over files.
354 get_the_right_time : DO
356 CALL wrf_get_next_time ( fid , date_string , status_next_var )
357 WRITE ( message , FMT = '(A,A,A,A,A,I5)' ) 'file date/time = ',date_string,' desired date = ',&
358 current_date_char,' status = ', status_next_var
359 CALL wrf_debug ( 99,message )
361 IF ( status_next_var .NE. 0 ) THEN
362 CALL wrf_debug ( 100 , 'ndown_em main: calling close_dataset for ' // TRIM(eligible_file_name(file_counter)) )
363 CALL close_dataset ( fid , config_flags , "DATASET=INPUT" )
364 file_counter = file_counter + 1
365 IF ( file_counter .GT. number_of_eligible_files ) THEN
366 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: opening too many files'
367 CALL WRF_ERROR_FATAL ( wrf_err_message )
368 END IF
369 CALL wrf_debug ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) )
370 CALL open_r_dataset ( fid, TRIM(eligible_file_name(file_counter)) , head_grid , config_flags , "DATASET=INPUT", ierr )
371 IF ( ierr .NE. 0 ) THEN
372 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(eligible_file_name(file_counter)), &
373 ' for reading ierr=',ierr
374 CALL WRF_ERROR_FATAL ( wrf_err_message )
375 ENDIF
376 CYCLE get_the_right_time
377 ELSE IF ( TRIM(date_string) .LT. TRIM(current_date_char) ) THEN
378 CYCLE get_the_right_time
379 ELSE IF ( TRIM(date_string) .EQ. TRIM(current_date_char) ) THEN
380 EXIT get_the_right_time
381 ELSE IF ( TRIM(date_string) .GT. TRIM(current_date_char) ) THEN
382 WRITE( wrf_err_message , FMT='(A,A,A,A,A)' ) 'Found ',TRIM(date_string),' before I found ',TRIM(current_date_char),'.'
383 CALL WRF_ERROR_FATAL ( wrf_err_message )
384 END IF
385 END DO get_the_right_time
387 CALL wrf_debug ( 100 , 'wrf: calling input_history' )
388 CALL wrf_get_previous_time ( fid , date_string , status_next_var )
389 WRITE ( message , * ) 'CFB' ,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,znw_c(1),znu_c(1)
390 CALL wrf_debug ( 99,message )
391 CALL input_history ( fid , head_grid , config_flags, ierr)
392 !!!!!!!!!!!!!1 mousta
393 cf1_c = head_grid%cf1
394 cf2_c = head_grid%cf2
395 cf3_c = head_grid%cf3
397 cfn_c = head_grid%cfn
398 cfn1_c = head_grid%cfn1
400 do k = 1,k_dim_c
401 znw_c(k) = head_grid%znw(k)
402 znu_c(k) = head_grid%znu(k)
403 enddo
404 call vert_cor(head_grid,znw_c,k_dim_c)
405 WRITE ( message , * ) 'CFA' ,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,znw_c(1),znu_c(1)
406 CALL wrf_debug ( 99,message )
407 WRITE ( message , * ) 'CFV' ,head_grid%cf1,head_grid%cf2,head_grid%cf3,head_grid%cfn,head_grid%cfn1,&
408 head_grid%znw(1),head_grid%znu(1) , head_grid%e_vert , parent_grid%cf1 , parent_grid%znw(1) , parent_grid%znu(1)
409 CALL wrf_debug ( 99,message )
410 !!!!!!!!!!!!!1 mousta
411 CALL wrf_debug ( 100 , 'wrf: back from input_history' )
413 ! Get the coarse grid info for later transfer to the fine grid domain.
415 CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , map_proj , 1 , icnt , ierr )
416 CALL wrf_get_dom_ti_real ( fid , 'DX' , dx , 1 , icnt , ierr )
417 CALL wrf_get_dom_ti_real ( fid , 'DY' , dy , 1 , icnt , ierr )
418 CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , cen_lat , 1 , icnt , ierr )
419 CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , cen_lon , 1 , icnt , ierr )
420 CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , truelat1 , 1 , icnt , ierr )
421 CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , truelat2 , 1 , icnt , ierr )
422 CALL wrf_get_dom_ti_real ( fid , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , icnt , ierr )
423 CALL wrf_get_dom_ti_real ( fid , 'STAND_LON' , stand_lon , 1 , icnt , ierr )
424 ! CALL wrf_get_dom_ti_real ( fid , 'GMT' , gmt , 1 , icnt , ierr )
425 ! CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , julyr , 1 , icnt , ierr )
426 ! CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , julday , 1 , icnt , ierr )
427 CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , iswater , 1 , icnt , ierr )
429 ! First time in, do this: allocate sapce for the fine grid, get the config flags, open the
430 ! wrfinput and wrfbdy files. This COULD be done outside the time loop, I think, so check it
431 ! out and move it up if you can.
433 IF ( time_loop .EQ. 1 ) THEN
435 CALL wrf_message ( program_name )
436 CALL wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain fine ' )
437 CALL alloc_and_configure_domain ( domain_id = 2 , &
438 grid = nested_grid , &
439 parent = parent_grid , &
440 kid = 1 )
442 CALL wrf_debug ( 100 , 'wrf: calling model_to_grid_config_rec ' )
443 CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
444 CALL wrf_debug ( 100 , 'wrf: calling set_scalar_indices_from_config ' )
445 CALL set_scalar_indices_from_config ( nested_grid%id , idum1, idum2 )
447 ! Set up time initializations for the fine grid.
449 CALL Setup_Timekeeping ( nested_grid )
450 ! Strictly speaking, nest stop time should come from model_config_rec...
451 CALL domain_clock_get( parent_grid, stop_timestr=stopTimeStr )
452 CALL domain_clock_set( nested_grid, &
453 current_timestr=current_date(1:19), &
454 stop_timestr=stopTimeStr , &
455 time_step_seconds= &
456 model_config_rec%interval_seconds )
458 ! Generate an output file from this program, which will be an input file to WRF.
460 CALL nl_set_bdyfrq ( nested_grid%id , new_bdy_frq )
461 config_flags%bdyfrq = new_bdy_frq
463 #ifdef WRF_CHEM
464 nested_grid%chem_opt = parent_grid%chem_opt
465 nested_grid%chem_in_opt = parent_grid%chem_in_opt
466 #endif
468 ! Initialize constants and 1d arrays in fine grid from the parent.
470 CALL init_domain_constants_em_ptr ( parent_grid , nested_grid )
472 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
474 CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfinput' )
475 CALL construct_filename1( outname , 'wrfinput' , nested_grid%id , 2 )
476 CALL open_w_dataset ( fido, TRIM(outname) , nested_grid , config_flags , output_input , "DATASET=INPUT", ierr )
477 IF ( ierr .NE. 0 ) THEN
478 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(outname),' for reading ierr=',ierr
479 CALL WRF_ERROR_FATAL ( wrf_err_message )
480 ENDIF
482 ! Various sizes that we need to be concerned about.
484 ids = nested_grid%sd31
485 ide = nested_grid%ed31
486 kds = nested_grid%sd32
487 kde = nested_grid%ed32
488 jds = nested_grid%sd33
489 jde = nested_grid%ed33
491 ims = nested_grid%sm31
492 ime = nested_grid%em31
493 kms = nested_grid%sm32
494 kme = nested_grid%em32
495 jms = nested_grid%sm33
496 jme = nested_grid%em33
498 ips = nested_grid%sp31
499 ipe = nested_grid%ep31
500 kps = nested_grid%sp32
501 kpe = nested_grid%ep32
502 jps = nested_grid%sp33
503 jpe = nested_grid%ep33
506 print *, ids , ide , jds , jde , kds , kde
507 print *, ims , ime , jms , jme , kms , kme
508 print *, ips , ipe , jps , jpe , kps , kpe
510 spec_bdy_width = model_config_rec%spec_bdy_width
511 print *,'spec_bdy_width=',spec_bdy_width
513 ! This is the space needed to save the current 3d data for use in computing
514 ! the lateral boundary tendencies.
516 ALLOCATE ( ubdy3dtemp1(ims:ime,kms:kme,jms:jme) )
517 ALLOCATE ( vbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
518 ALLOCATE ( tbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
519 ALLOCATE ( pbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
520 ALLOCATE ( qbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
521 ALLOCATE ( mbdy2dtemp1(ims:ime,1:1, jms:jme) )
522 ALLOCATE ( ubdy3dtemp2(ims:ime,kms:kme,jms:jme) )
523 ALLOCATE ( vbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
524 ALLOCATE ( tbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
525 ALLOCATE ( pbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
526 ALLOCATE ( qbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
527 ALLOCATE ( mbdy2dtemp2(ims:ime,1:1, jms:jme) )
528 ALLOCATE ( cbdy3dtemp0(ims:ime,kms:kme,jms:jme,1:num_chem) )
529 ALLOCATE ( cbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
530 ALLOCATE ( cbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
532 END IF
534 CALL domain_clock_set( nested_grid, &
535 current_timestr=current_date(1:19), &
536 time_step_seconds= &
537 model_config_rec%interval_seconds )
539 ! Do the horizontal interpolation.
541 nested_grid%imask_nostag = 1
542 nested_grid%imask_xstag = 1
543 nested_grid%imask_ystag = 1
544 nested_grid%imask_xystag = 1
546 CALL med_interp_domain ( head_grid , nested_grid )
547 WRITE ( message , * ) 'MOUSTA_L', nested_grid%mu_2(ips,jps) , nested_grid%u_2(ips,kde-2,jps)
548 CALL wrf_debug ( 99,message )
549 CALL vertical_interp (nested_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c)
550 WRITE ( message , * ) 'MOUSTA_V', nested_grid%mu_2(ips,jps) , nested_grid%u_2(ips,kde-2,jps)
551 CALL wrf_debug ( 99,message )
552 nested_grid%ht_int = nested_grid%ht
554 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
556 IF ( time_loop .EQ. 1 ) THEN
558 ! Dimension info for fine grid.
560 CALL get_ijk_from_grid ( nested_grid , &
561 nids, nide, njds, njde, nkds, nkde, &
562 nims, nime, njms, njme, nkms, nkme, &
563 nips, nipe, njps, njpe, nkps, nkpe )
565 ! Store horizontally interpolated terrain in temp location
567 CALL copy_3d_field ( nested_grid%ht_fine , nested_grid%ht , &
568 nids , nide , njds , njde , 1 , 1 , &
569 nims , nime , njms , njme , 1 , 1 , &
570 nips , nipe , njps , njpe , 1 , 1 )
572 ! Open the fine grid SI static file.
574 CALL construct_filename1( si_inpname , 'wrfndi' , nested_grid%id , 2 )
575 CALL wrf_debug ( 100 , 'med_sidata_input: calling open_r_dataset for ' // TRIM(si_inpname) )
576 CALL open_r_dataset ( idsi, TRIM(si_inpname) , nested_grid , config_flags , "DATASET=INPUT", ierr )
577 IF ( ierr .NE. 0 ) THEN
578 CALL wrf_error_fatal( 'real: error opening FG input for reading: ' // TRIM (si_inpname) )
579 END IF
581 ! Input data.
583 CALL wrf_debug ( 100 , 'ndown_em: calling input_auxinput2' )
584 CALL input_auxinput2 ( idsi , nested_grid , config_flags , ierr )
585 nested_grid%ht_input = nested_grid%ht
587 ! Close this fine grid static input file.
589 CALL wrf_debug ( 100 , 'ndown_em: closing fine grid static input' )
590 CALL close_dataset ( idsi , config_flags , "DATASET=INPUT" )
592 ! Blend parent and nest field of terrain.
594 CALL blend_terrain ( nested_grid%ht_fine , nested_grid%ht , &
595 nids , nide , njds , njde , 1 , 1 , &
596 nims , nime , njms , njme , 1 , 1 , &
597 nips , nipe , njps , njpe , 1 , 1 )
599 nested_grid%ht_input = nested_grid%ht
600 nested_grid%ht_int = nested_grid%ht_fine
602 ! We need a fine grid landuse in the interpolation. So we need to generate
603 ! that field now.
605 IF ( ( nested_grid%ivgtyp(ips,jps) .GT. 0 ) .AND. &
606 ( nested_grid%isltyp(ips,jps) .GT. 0 ) ) THEN
607 DO j = jps, MIN(jde-1,jpe)
608 DO i = ips, MIN(ide-1,ipe)
609 nested_grid% vegcat(i,j) = nested_grid%ivgtyp(i,j)
610 nested_grid%soilcat(i,j) = nested_grid%isltyp(i,j)
611 END DO
612 END DO
614 ELSE IF ( ( nested_grid% vegcat(ips,jps) .GT. 0.5 ) .AND. &
615 ( nested_grid%soilcat(ips,jps) .GT. 0.5 ) ) THEN
616 DO j = jps, MIN(jde-1,jpe)
617 DO i = ips, MIN(ide-1,ipe)
618 nested_grid%ivgtyp(i,j) = NINT(nested_grid% vegcat(i,j))
619 nested_grid%isltyp(i,j) = NINT(nested_grid%soilcat(i,j))
620 END DO
621 END DO
623 ELSE
624 num_veg_cat = SIZE ( nested_grid%landusef , DIM=2 )
625 num_soil_top_cat = SIZE ( nested_grid%soilctop , DIM=2 )
626 num_soil_bot_cat = SIZE ( nested_grid%soilcbot , DIM=2 )
628 CALL land_percentages ( nested_grid%xland , &
629 nested_grid%landusef , nested_grid%soilctop , nested_grid%soilcbot , &
630 nested_grid%isltyp , nested_grid%ivgtyp , &
631 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
632 ids , ide , jds , jde , kds , kde , &
633 ims , ime , jms , jme , kms , kme , &
634 ips , ipe , jps , jpe , kps , kpe , &
635 model_config_rec%iswater(nested_grid%id) )
637 END IF
639 DO j = jps, MIN(jde-1,jpe)
640 DO i = ips, MIN(ide-1,ipe)
641 nested_grid%lu_index(i,j) = nested_grid%ivgtyp(i,j)
642 END DO
643 END DO
645 #ifndef PLANET
646 CALL check_consistency ( nested_grid%ivgtyp , nested_grid%isltyp , nested_grid%landmask , &
647 ids , ide , jds , jde , kds , kde , &
648 ims , ime , jms , jme , kms , kme , &
649 ips , ipe , jps , jpe , kps , kpe , &
650 model_config_rec%iswater(nested_grid%id) )
652 CALL check_consistency2( nested_grid%ivgtyp , nested_grid%isltyp , nested_grid%landmask , &
653 nested_grid%tmn , nested_grid%tsk , nested_grid%sst , nested_grid%xland , &
654 nested_grid%tslb , nested_grid%smois , nested_grid%sh2o , &
655 config_flags%num_soil_layers , nested_grid%id , &
656 ids , ide , jds , jde , kds , kde , &
657 ims , ime , jms , jme , kms , kme , &
658 ips , ipe , jps , jpe , kps , kpe , &
659 model_config_rec%iswater(nested_grid%id) )
660 #endif
662 END IF
664 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
666 ! We have 2 terrain elevations. One is from input and the other is from the
667 ! the horizontal interpolation.
669 nested_grid%ht_fine = nested_grid%ht_input
670 nested_grid%ht = nested_grid%ht_int
672 ! We have both the interpolated fields and the higher-resolution static fields. From these
673 ! the rebalancing is now done. Note also that the field nested_grid%ht is now from the
674 ! fine grid input file (after this call is completed).
676 CALL rebalance_driver ( nested_grid )
678 ! Different things happen during the different time loops:
679 ! first loop - write wrfinput file, close data set, copy files to holder arrays
680 ! middle loops - diff 3d/2d arrays, compute and output bc
681 ! last loop - diff 3d/2d arrays, compute and output bc, write wrfbdy file, close wrfbdy file
683 IF ( time_loop .EQ. 1 ) THEN
685 ! Set the time info.
687 print *,'current_date = ',current_date
688 CALL domain_clock_set( nested_grid, &
689 current_timestr=current_date(1:19) )
690 #ifdef WRF_CHEM
691 !
692 ! Put in chemistry data
693 !
694 IF( nested_grid%chem_opt .NE. 0 ) then
695 ! IF( nested_grid%chem_in_opt .EQ. 0 ) then
696 ! Read the chemistry data from a previous wrf forecast (wrfout file)
697 ! Generate chemistry data from a idealized vertical profile
698 ! message = 'STARTING WITH BACKGROUND CHEMISTRY '
699 CALL wrf_message ( message )
701 ! CALL input_chem_profile ( nested_grid )
703 if(nested_grid%biomass_burn_opt == BIOMASSB) THEN
704 message = 'READING BIOMASS BURNING EMISSIONS DATA '
705 CALL wrf_message ( message )
706 CALL med_read_wrf_chem_emissopt3 ( nested_grid , config_flags)
707 end if
709 if(nested_grid%dust_opt == 1 .or. nested_grid%dmsemis_opt == 1 &
710 .or. nested_grid%chem_opt == 300 .or. nested_grid%chem_opt == 301) then
711 message = 'READING GOCART BG AND/OR DUST and DMS REF FIELDS'
712 CALL wrf_message ( message )
713 CALL med_read_wrf_chem_gocart_bg ( nested_grid , config_flags)
714 end if
716 if( nested_grid%bio_emiss_opt .eq. 2 )then
717 message = 'READING BEIS3.11 EMISSIONS DATA'
718 CALL wrf_message ( message )
719 CALL med_read_wrf_chem_bioemiss ( nested_grid , config_flags)
720 else if( nested_grid%bio_emiss_opt == 3 ) THEN
721 message = 'READING MEGAN 2 EMISSIONS DATA'
722 CALL wrf_message ( message )
723 CALL med_read_wrf_chem_bioemiss ( nested_grid , config_flags)
724 endif
725 ! ELSE
726 ! message = 'RUNNING WITHOUT CHEMISTRY INITIALIZATION'
727 ! CALL wrf_message ( message )
728 ! ENDIF
729 ENDIF
730 #endif
732 ! Output the first time period of the data.
734 CALL output_input ( fido , nested_grid , config_flags , ierr )
736 CALL wrf_put_dom_ti_integer ( fido , 'MAP_PROJ' , map_proj , 1 , ierr )
737 ! CALL wrf_put_dom_ti_real ( fido , 'DX' , dx , 1 , ierr )
738 ! CALL wrf_put_dom_ti_real ( fido , 'DY' , dy , 1 , ierr )
739 CALL wrf_put_dom_ti_real ( fido , 'CEN_LAT' , cen_lat , 1 , ierr )
740 CALL wrf_put_dom_ti_real ( fido , 'CEN_LON' , cen_lon , 1 , ierr )
741 CALL wrf_put_dom_ti_real ( fido , 'TRUELAT1' , truelat1 , 1 , ierr )
742 CALL wrf_put_dom_ti_real ( fido , 'TRUELAT2' , truelat2 , 1 , ierr )
743 CALL wrf_put_dom_ti_real ( fido , 'MOAD_CEN_LAT' , moad_cen_lat , 1 , ierr )
744 CALL wrf_put_dom_ti_real ( fido , 'STAND_LON' , stand_lon , 1 , ierr )
745 CALL wrf_put_dom_ti_integer ( fido , 'ISWATER' , iswater , 1 , ierr )
747 ! These change if the initial time for the nest is not the same as the
748 ! first time period in the WRF output file.
749 ! Now that we know the starting date, we need to set the GMT, JULYR, and JULDAY
750 ! values for the global attributes. This call is based on the setting of the
751 ! current_date string.
753 CALL geth_julgmt ( julyr , julday , gmt)
754 CALL nl_set_julyr ( nested_grid%id , julyr )
755 CALL nl_set_julday ( nested_grid%id , julday )
756 CALL nl_set_gmt ( nested_grid%id , gmt )
757 CALL wrf_put_dom_ti_real ( fido , 'GMT' , gmt , 1 , ierr )
758 CALL wrf_put_dom_ti_integer ( fido , 'JULYR' , julyr , 1 , ierr )
759 CALL wrf_put_dom_ti_integer ( fido , 'JULDAY' , julday , 1 , ierr )
760 print *,'current_date =',current_date
761 print *,'julyr=',julyr
762 print *,'julday=',julday
763 print *,'gmt=',gmt
765 ! Close the input (wrfout_d01_000000, for example) file. That's right, the
766 ! input is an output file. Who'd've thunk.
768 CALL close_dataset ( fido , config_flags , "DATASET=INPUT" )
770 ! We need to save the 3d/2d data to compute a difference during the next loop. Couple the
771 ! 3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor.
773 ! u, theta, h, scalars coupled with my, v coupled with mx
774 CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp1 , nested_grid%u_2 , &
775 'u' , nested_grid%msfuy , &
776 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
777 CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp1 , nested_grid%v_2 , &
778 'v' , nested_grid%msfvx , &
779 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
780 CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp1 , nested_grid%t_2 , &
781 't' , nested_grid%msfty , &
782 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
783 CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp1 , nested_grid%ph_2 , &
784 'h' , nested_grid%msfty , &
785 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
786 CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp1 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV) , &
787 't' , nested_grid%msfty , &
788 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
790 DO j = jps , jpe
791 DO i = ips , ipe
792 mbdy2dtemp1(i,1,j) = nested_grid%mu_2(i,j)
793 END DO
794 END DO
796 ! There are 2 components to the lateral boundaries. First, there is the starting
797 ! point of this time period - just the outer few rows and columns.
799 CALL stuff_bdy ( ubdy3dtemp1 , nested_grid%u_bxs, nested_grid%u_bxe, &
800 nested_grid%u_bys, nested_grid%u_bye, &
801 'U' , spec_bdy_width , &
802 ids , ide , jds , jde , kds , kde , &
803 ims , ime , jms , jme , kms , kme , &
804 ips , ipe , jps , jpe , kps , kpe )
805 CALL stuff_bdy ( vbdy3dtemp1 , nested_grid%v_bxs, nested_grid%v_bxe, &
806 nested_grid%v_bys, nested_grid%v_bye, &
807 'V' , spec_bdy_width , &
808 ids , ide , jds , jde , kds , kde , &
809 ims , ime , jms , jme , kms , kme , &
810 ips , ipe , jps , jpe , kps , kpe )
811 CALL stuff_bdy ( tbdy3dtemp1 , nested_grid%t_bxs, nested_grid%t_bxe, &
812 nested_grid%t_bys, nested_grid%t_bye, &
813 'T' , spec_bdy_width , &
814 ids , ide , jds , jde , kds , kde , &
815 ims , ime , jms , jme , kms , kme , &
816 ips , ipe , jps , jpe , kps , kpe )
817 CALL stuff_bdy ( pbdy3dtemp1 , nested_grid%ph_bxs, nested_grid%ph_bxe, &
818 nested_grid%ph_bys, nested_grid%ph_bye, &
819 'W' , spec_bdy_width , &
820 ids , ide , jds , jde , kds , kde , &
821 ims , ime , jms , jme , kms , kme , &
822 ips , ipe , jps , jpe , kps , kpe )
823 CALL stuff_bdy ( qbdy3dtemp1 , nested_grid%moist_bxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
824 nested_grid%moist_bxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
825 nested_grid%moist_bys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
826 nested_grid%moist_bye(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
827 'T' , spec_bdy_width , &
828 ids , ide , jds , jde , kds , kde , &
829 ims , ime , jms , jme , kms , kme , &
830 ips , ipe , jps , jpe , kps , kpe )
831 CALL stuff_bdy ( mbdy2dtemp1 , nested_grid%mu_bxs, nested_grid%mu_bxe, &
832 nested_grid%mu_bys, nested_grid%mu_bye, &
833 'M' , spec_bdy_width , &
834 ids , ide , jds , jde , 1 , 1 , &
835 ims , ime , jms , jme , 1 , 1 , &
836 ips , ipe , jps , jpe , 1 , 1 )
837 #ifdef WRF_CHEM
838 do nvchem=1,num_chem
839 ! if(nvchem.eq.p_o3)then
840 ! write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5),nvchem
841 ! endif
842 cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
843 ! if(nvchem.eq.p_o3)then
844 ! write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5)
845 ! endif
846 CALL stuff_bdy ( cbdy3dtemp1 , nested_grid%chem_bxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
847 nested_grid%chem_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
848 nested_grid%chem_bys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
849 nested_grid%chem_bye(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
850 'T' , spec_bdy_width , &
851 ids , ide , jds , jde , kds , kde , &
852 ims , ime , jms , jme , kms , kme , &
853 ips , ipe , jps , jpe , kps , kpe )
854 cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)
855 ! if(nvchem.eq.p_o3)then
856 ! write(0,*)'filled ch_b',time_loop,cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
857 ! endif
858 enddo
859 #endif
860 ELSE IF ( ( time_loop .GT. 1 ) .AND. ( time_loop .LT. time_loop_max ) ) THEN
862 ! u, theta, h, scalars coupled with my, v coupled with mx
863 CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp2 , nested_grid%u_2 , &
864 'u' , nested_grid%msfuy , &
865 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
866 CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp2 , nested_grid%v_2 , &
867 'v' , nested_grid%msfvx , &
868 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
869 CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp2 , nested_grid%t_2 , &
870 't' , nested_grid%msfty , &
871 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
872 CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp2 , nested_grid%ph_2 , &
873 'h' , nested_grid%msfty , &
874 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
875 CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp2 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV) , &
876 't' , nested_grid%msfty , &
877 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
879 DO j = jps , jpe
880 DO i = ips , ipe
881 mbdy2dtemp2(i,1,j) = nested_grid%mu_2(i,j)
882 END DO
883 END DO
885 ! During all of the loops after the first loop, we first compute the boundary
886 ! tendencies with the current data values and the previously save information
887 ! stored in the *bdy3dtemp1 arrays.
889 CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , new_bdy_frq , &
890 nested_grid%u_btxs, nested_grid%u_btxe , &
891 nested_grid%u_btys, nested_grid%u_btye , &
892 'U' , &
893 spec_bdy_width , &
894 ids , ide , jds , jde , kds , kde , &
895 ims , ime , jms , jme , kms , kme , &
896 ips , ipe , jps , jpe , kps , kpe )
897 CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , new_bdy_frq , &
898 nested_grid%v_btxs, nested_grid%v_btxe , &
899 nested_grid%v_btys, nested_grid%v_btye , &
900 'V' , &
901 spec_bdy_width , &
902 ids , ide , jds , jde , kds , kde , &
903 ims , ime , jms , jme , kms , kme , &
904 ips , ipe , jps , jpe , kps , kpe )
905 CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , new_bdy_frq , &
906 nested_grid%t_btxs, nested_grid%t_btxe , &
907 nested_grid%t_btys, nested_grid%t_btye , &
908 'T' , &
909 spec_bdy_width , &
910 ids , ide , jds , jde , kds , kde , &
911 ims , ime , jms , jme , kms , kme , &
912 ips , ipe , jps , jpe , kps , kpe )
913 CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , new_bdy_frq , &
914 nested_grid%ph_btxs, nested_grid%ph_btxe , &
915 nested_grid%ph_btys, nested_grid%ph_btye , &
916 'W' , &
917 spec_bdy_width , &
918 ids , ide , jds , jde , kds , kde , &
919 ims , ime , jms , jme , kms , kme , &
920 ips , ipe , jps , jpe , kps , kpe )
921 CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , new_bdy_frq , &
922 nested_grid%moist_btxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
923 nested_grid%moist_btxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
924 nested_grid%moist_btys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
925 nested_grid%moist_btye(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
926 'T' , &
927 spec_bdy_width , &
928 ids , ide , jds , jde , kds , kde , &
929 ims , ime , jms , jme , kms , kme , &
930 ips , ipe , jps , jpe , kps , kpe )
931 CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , &
932 nested_grid%mu_btxs, nested_grid%mu_btxe , &
933 nested_grid%mu_btys, nested_grid%mu_btye , &
934 'M' , &
935 spec_bdy_width , &
936 ids , ide , jds , jde , 1 , 1 , &
937 ims , ime , jms , jme , 1 , 1 , &
938 ips , ipe , jps , jpe , 1 , 1 )
939 #ifdef WRF_CHEM
940 do nvchem=1,num_chem
941 cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
942 cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
943 ! if(nvchem.eq.p_o3)then
944 ! write(0,*)'fill 1ch_b2',time_loop,cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
945 ! endif
946 CALL stuff_bdytend ( cbdy3dtemp2 , cbdy3dtemp1 , new_bdy_frq , &
947 nested_grid%chem_btxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
948 nested_grid%chem_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
949 nested_grid%chem_btys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
950 nested_grid%chem_btye(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
951 'T' , &
952 spec_bdy_width , &
953 ids , ide , jds , jde , kds , kde , &
954 ims , ime , jms , jme , kms , kme , &
955 ips , ipe , jps , jpe , kps , kpe )
956 cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)
957 ! if(nvchem.eq.p_o3)then
958 ! write(0,*)'fill 2ch_b2',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
959 ! endif
960 enddo
961 #endif
962 IF ( time_loop .EQ. 2 ) THEN
964 ! Generate an output file from this program, which will be an input file to WRF.
966 CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfbdy' )
967 CALL construct_filename1( bdyname , 'wrfbdy' , nested_grid%id , 2 )
968 CALL open_w_dataset ( fidb, TRIM(bdyname) , nested_grid , config_flags , output_boundary , &
969 "DATASET=BOUNDARY", ierr )
970 IF ( ierr .NE. 0 ) THEN
971 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(bdyname),' for reading ierr=',ierr
972 CALL WRF_ERROR_FATAL ( wrf_err_message )
973 ENDIF
975 END IF
977 ! Both pieces of the boundary data are now available to be written.
979 CALL domain_clock_set( nested_grid, &
980 current_timestr=current_date(1:19) )
981 temp24= current_date
982 temp24b=start_date_hold
983 start_date = start_date_hold
984 CALL geth_newdate ( temp19 , temp24b(1:19) , (time_loop-2) * model_config_rec%interval_seconds )
985 current_date = temp19 // '.0000'
986 CALL geth_julgmt ( julyr , julday , gmt)
987 CALL nl_set_julyr ( nested_grid%id , julyr )
988 CALL nl_set_julday ( nested_grid%id , julday )
989 CALL nl_set_gmt ( nested_grid%id , gmt )
990 CALL wrf_put_dom_ti_real ( fidb , 'GMT' , gmt , 1 , ierr )
991 CALL wrf_put_dom_ti_integer ( fidb , 'JULYR' , julyr , 1 , ierr )
992 CALL wrf_put_dom_ti_integer ( fidb , 'JULDAY' , julday , 1 , ierr )
993 CALL domain_clock_set( nested_grid, &
994 current_timestr=current_date(1:19) )
995 print *,'bdy time = ',time_loop-1,' bdy date = ',current_date,' ',start_date
996 CALL output_boundary ( fidb , nested_grid , config_flags , ierr )
997 current_date = temp24
998 start_date = temp24b
999 CALL domain_clock_set( nested_grid, &
1000 current_timestr=current_date(1:19) )
1002 IF ( time_loop .EQ. 2 ) THEN
1003 CALL wrf_put_dom_ti_real ( fidb , 'BDYFRQ' , new_bdy_frq , 1 , ierr )
1004 END IF
1006 ! We need to save the 3d data to compute a difference during the next loop. Couple the
1007 ! 3d fields with total mu (mub + mu_2) and the stagger-specific map scale factor.
1008 ! We load up the boundary data again for use in the next loop.
1010 DO j = jps , jpe
1011 DO k = kps , kpe
1012 DO i = ips , ipe
1013 ubdy3dtemp1(i,k,j) = ubdy3dtemp2(i,k,j)
1014 vbdy3dtemp1(i,k,j) = vbdy3dtemp2(i,k,j)
1015 tbdy3dtemp1(i,k,j) = tbdy3dtemp2(i,k,j)
1016 pbdy3dtemp1(i,k,j) = pbdy3dtemp2(i,k,j)
1017 qbdy3dtemp1(i,k,j) = qbdy3dtemp2(i,k,j)
1018 END DO
1019 END DO
1020 END DO
1022 DO j = jps , jpe
1023 DO i = ips , ipe
1024 mbdy2dtemp1(i,1,j) = mbdy2dtemp2(i,1,j)
1025 END DO
1026 END DO
1028 ! There are 2 components to the lateral boundaries. First, there is the starting
1029 ! point of this time period - just the outer few rows and columns.
1031 CALL stuff_bdy ( ubdy3dtemp1 , &
1032 nested_grid%u_bxs, nested_grid%u_bxe , &
1033 nested_grid%u_bys, nested_grid%u_bye , &
1034 'U' , spec_bdy_width , &
1035 ids , ide , jds , jde , kds , kde , &
1036 ims , ime , jms , jme , kms , kme , &
1037 ips , ipe , jps , jpe , kps , kpe )
1038 CALL stuff_bdy ( vbdy3dtemp1 , &
1039 nested_grid%v_bxs, nested_grid%v_bxe , &
1040 nested_grid%v_bys, nested_grid%v_bye , &
1041 'V' , spec_bdy_width , &
1042 ids , ide , jds , jde , kds , kde , &
1043 ims , ime , jms , jme , kms , kme , &
1044 ips , ipe , jps , jpe , kps , kpe )
1045 CALL stuff_bdy ( tbdy3dtemp1 , &
1046 nested_grid%t_bxs, nested_grid%t_bxe , &
1047 nested_grid%t_bys, nested_grid%t_bye , &
1048 'T' , spec_bdy_width , &
1049 ids , ide , jds , jde , kds , kde , &
1050 ims , ime , jms , jme , kms , kme , &
1051 ips , ipe , jps , jpe , kps , kpe )
1052 CALL stuff_bdy ( pbdy3dtemp1 , &
1053 nested_grid%ph_bxs, nested_grid%ph_bxe , &
1054 nested_grid%ph_bys, nested_grid%ph_bye , &
1055 'W' , spec_bdy_width , &
1056 ids , ide , jds , jde , kds , kde , &
1057 ims , ime , jms , jme , kms , kme , &
1058 ips , ipe , jps , jpe , kps , kpe )
1059 CALL stuff_bdy ( qbdy3dtemp1 , &
1060 nested_grid%moist_bxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
1061 nested_grid%moist_bxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV), &
1062 nested_grid%moist_bys(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
1063 nested_grid%moist_bye(ims:ime,kms:kme,1:spec_bdy_width,P_QV), &
1064 'T' , spec_bdy_width , &
1065 ids , ide , jds , jde , kds , kde , &
1066 ims , ime , jms , jme , kms , kme , &
1067 ips , ipe , jps , jpe , kps , kpe )
1068 #ifdef WRF_CHEM
1069 do nvchem=1,num_chem
1070 cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
1071 ! if(nvchem.eq.p_o3)then
1072 ! write(0,*)'fill 2ch_b3',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
1073 ! endif
1074 CALL stuff_bdy ( cbdy3dtemp1 , &
1075 nested_grid%chem_bxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
1076 nested_grid%chem_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
1077 nested_grid%chem_bys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
1078 nested_grid%chem_bye(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
1079 'T' , spec_bdy_width , &
1080 ids , ide , jds , jde , kds , kde , &
1081 ims , ime , jms , jme , kms , kme , &
1082 ips , ipe , jps , jpe , kps , kpe )
1083 ! cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)
1084 ! if(nvchem.eq.p_o3)then
1085 ! write(0,*)'fill 2ch_b3',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem)
1086 ! endif
1087 enddo
1088 #endif
1089 CALL stuff_bdy ( mbdy2dtemp1 , &
1090 nested_grid%mu_bxs, nested_grid%mu_bxe , &
1091 nested_grid%mu_bys, nested_grid%mu_bye , &
1092 'M' , spec_bdy_width , &
1093 ids , ide , jds , jde , 1 , 1 , &
1094 ims , ime , jms , jme , 1 , 1 , &
1095 ips , ipe , jps , jpe , 1 , 1 )
1097 ELSE IF ( time_loop .EQ. time_loop_max ) THEN
1099 ! u, theta, h, scalars coupled with my, v coupled with mx
1100 CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp2 , nested_grid%u_2 , &
1101 'u' , nested_grid%msfuy , &
1102 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1103 CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp2 , nested_grid%v_2 , &
1104 'v' , nested_grid%msfvx , &
1105 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1106 CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp2 , nested_grid%t_2 , &
1107 't' , nested_grid%msfty , &
1108 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1109 CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp2 , nested_grid%ph_2 , &
1110 'h' , nested_grid%msfty , &
1111 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1112 CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp2 , nested_grid%moist(ims:ime,kms:kme,jms:jme,P_QV) , &
1113 't' , nested_grid%msfty , &
1114 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
1115 mbdy2dtemp2(:,1,:) = nested_grid%mu_2(:,:)
1117 ! During all of the loops after the first loop, we first compute the boundary
1118 ! tendencies with the current data values and the previously save information
1119 ! stored in the *bdy3dtemp1 arrays.
1120 #ifdef WRF_CHEM
1121 do nvchem=1,num_chem
1122 cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)
1123 cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem)
1124 ! if(nvchem.eq.p_o3)then
1125 ! write(0,*)'fill 1ch_b4',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
1126 ! endif
1127 CALL stuff_bdytend ( cbdy3dtemp2 , cbdy3dtemp1 , new_bdy_frq , &
1128 nested_grid%chem_btxs(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
1129 nested_grid%chem_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvchem), &
1130 nested_grid%chem_btys(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
1131 nested_grid%chem_btye(ims:ime,kms:kme,1:spec_bdy_width,nvchem), &
1132 'T' , &
1133 spec_bdy_width , &
1134 ids , ide , jds , jde , kds , kde , &
1135 ims , ime , jms , jme , kms , kme , &
1136 ips , ipe , jps , jpe , kps , kpe )
1137 cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem)=cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)
1138 ! if(nvchem.eq.p_o3)then
1139 ! write(0,*)'fill 2ch_b4',cbdy3dtemp1(ips,kps,jps),cbdy3dtemp0(ips,kps,jps,nvchem),cbdy3dtemp2(ips,kps,jps)
1140 ! endif
1141 enddo
1142 #endif
1144 CALL stuff_bdytend ( ubdy3dtemp2 , ubdy3dtemp1 , new_bdy_frq , &
1145 nested_grid%u_btxs , nested_grid%u_btxe , &
1146 nested_grid%u_btys , nested_grid%u_btye , &
1147 'U' , &
1148 spec_bdy_width , &
1149 ids , ide , jds , jde , kds , kde , &
1150 ims , ime , jms , jme , kms , kme , &
1151 ips , ipe , jps , jpe , kps , kpe )
1152 CALL stuff_bdytend ( vbdy3dtemp2 , vbdy3dtemp1 , new_bdy_frq , &
1153 nested_grid%v_btxs , nested_grid%v_btxe , &
1154 nested_grid%v_btys , nested_grid%v_btye , &
1155 'V' , &
1156 spec_bdy_width , &
1157 ids , ide , jds , jde , kds , kde , &
1158 ims , ime , jms , jme , kms , kme , &
1159 ips , ipe , jps , jpe , kps , kpe )
1160 CALL stuff_bdytend ( tbdy3dtemp2 , tbdy3dtemp1 , new_bdy_frq , &
1161 nested_grid%t_btxs , nested_grid%t_btxe , &
1162 nested_grid%t_btys , nested_grid%t_btye , &
1163 'T' , &
1164 spec_bdy_width , &
1165 ids , ide , jds , jde , kds , kde , &
1166 ims , ime , jms , jme , kms , kme , &
1167 ips , ipe , jps , jpe , kps , kpe )
1168 CALL stuff_bdytend ( pbdy3dtemp2 , pbdy3dtemp1 , new_bdy_frq , &
1169 nested_grid%ph_btxs , nested_grid%ph_btxe , &
1170 nested_grid%ph_btys , nested_grid%ph_btye , &
1171 'W' , &
1172 spec_bdy_width , &
1173 ids , ide , jds , jde , kds , kde , &
1174 ims , ime , jms , jme , kms , kme , &
1175 ips , ipe , jps , jpe , kps , kpe )
1176 CALL stuff_bdytend ( qbdy3dtemp2 , qbdy3dtemp1 , new_bdy_frq , &
1177 nested_grid%moist_btxs(jms:jme,kms:kme,1:spec_bdy_width,P_QV) , &
1178 nested_grid%moist_btxe(jms:jme,kms:kme,1:spec_bdy_width,P_QV) , &
1179 nested_grid%moist_btys(ims:ime,kms:kme,1:spec_bdy_width,P_QV) , &
1180 nested_grid%moist_btye(ims:ime,kms:kme,1:spec_bdy_width,P_QV) , &
1181 'T' , &
1182 spec_bdy_width , &
1183 ids , ide , jds , jde , kds , kde , &
1184 ims , ime , jms , jme , kms , kme , &
1185 ips , ipe , jps , jpe , kps , kpe )
1186 CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , &
1187 nested_grid%mu_btxs , nested_grid%mu_btxe , &
1188 nested_grid%mu_btys , nested_grid%mu_btye , &
1189 'M' , &
1190 spec_bdy_width , &
1191 ids , ide , jds , jde , 1 , 1 , &
1192 ims , ime , jms , jme , 1 , 1 , &
1193 ips , ipe , jps , jpe , 1 , 1 )
1195 IF ( time_loop .EQ. 2 ) THEN
1197 ! Generate an output file from this program, which will be an input file to WRF.
1199 CALL wrf_debug ( 100 , 'ndown_em main: calling open_w_dataset for wrfbdy' )
1200 CALL construct_filename1( bdyname , 'wrfbdy' , nested_grid%id , 2 )
1201 CALL open_w_dataset ( fidb, TRIM(bdyname) , nested_grid , config_flags , output_boundary , &
1202 "DATASET=BOUNDARY", ierr )
1203 IF ( ierr .NE. 0 ) THEN
1204 WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: error opening ',TRIM(bdyname),' for reading ierr=',ierr
1205 CALL WRF_ERROR_FATAL ( wrf_err_message )
1206 ENDIF
1208 END IF
1210 ! Both pieces of the boundary data are now available to be written.
1212 CALL domain_clock_set( nested_grid, &
1213 current_timestr=current_date(1:19) )
1214 temp24= current_date
1215 temp24b=start_date_hold
1216 start_date = start_date_hold
1217 CALL geth_newdate ( temp19 , temp24b(1:19) , (time_loop-2) * model_config_rec%interval_seconds )
1218 current_date = temp19 // '.0000'
1219 CALL geth_julgmt ( julyr , julday , gmt)
1220 CALL nl_set_julyr ( nested_grid%id , julyr )
1221 CALL nl_set_julday ( nested_grid%id , julday )
1222 CALL nl_set_gmt ( nested_grid%id , gmt )
1223 CALL wrf_put_dom_ti_real ( fidb , 'GMT' , gmt , 1 , ierr )
1224 CALL wrf_put_dom_ti_integer ( fidb , 'JULYR' , julyr , 1 , ierr )
1225 CALL wrf_put_dom_ti_integer ( fidb , 'JULDAY' , julday , 1 , ierr )
1226 CALL domain_clock_set( nested_grid, &
1227 current_timestr=current_date(1:19) )
1228 CALL output_boundary ( fidb , nested_grid , config_flags , ierr )
1229 current_date = temp24
1230 start_date = temp24b
1231 CALL domain_clock_set( nested_grid, &
1232 current_timestr=current_date(1:19) )
1234 IF ( time_loop .EQ. 2 ) THEN
1235 CALL wrf_put_dom_ti_real ( fidb , 'BDYFRQ' , new_bdy_frq , 1 , ierr )
1236 END IF
1238 ! Since this is the last time through here, we need to close the boundary file.
1240 CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
1241 CALL close_dataset ( fidb , config_flags , "DATASET=BOUNDARY" )
1244 END IF
1246 ! Process which time now?
1248 END DO big_time_loop_thingy
1249 DEALLOCATE(znw_c)
1250 DEALLOCATE(znu_c)
1251 CALL model_to_grid_config_rec ( parent_grid%id , model_config_rec , config_flags )
1252 CALL med_shutdown_io ( parent_grid , config_flags )
1254 CALL wrf_debug ( 0 , 'ndown_em: SUCCESS COMPLETE NDOWN_EM INIT' )
1256 CALL wrf_shutdown
1258 CALL WRFU_Finalize( rc=rc )
1260 END PROGRAM ndown_em
1262 SUBROUTINE land_percentages ( xland , &
1263 landuse_frac , soil_top_cat , soil_bot_cat , &
1264 isltyp , ivgtyp , &
1265 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
1266 ids , ide , jds , jde , kds , kde , &
1267 ims , ime , jms , jme , kms , kme , &
1268 its , ite , jts , jte , kts , kte , &
1269 iswater )
1270 USE module_soil_pre
1272 IMPLICIT NONE
1274 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1275 ims , ime , jms , jme , kms , kme , &
1276 its , ite , jts , jte , kts , kte , &
1277 iswater
1279 INTEGER , INTENT(IN) :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
1280 REAL , DIMENSION(ims:ime,1:num_veg_cat,jms:jme) , INTENT(INOUT):: landuse_frac
1281 REAL , DIMENSION(ims:ime,1:num_soil_top_cat,jms:jme) , INTENT(IN):: soil_top_cat
1282 REAL , DIMENSION(ims:ime,1:num_soil_bot_cat,jms:jme) , INTENT(IN):: soil_bot_cat
1283 INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(OUT) :: isltyp , ivgtyp
1284 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: xland
1286 CALL process_percent_cat_new ( xland , &
1287 landuse_frac , soil_top_cat , soil_bot_cat , &
1288 isltyp , ivgtyp , &
1289 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
1290 ids , ide , jds , jde , kds , kde , &
1291 ims , ime , jms , jme , kms , kme , &
1292 its , ite , jts , jte , kts , kte , &
1293 iswater )
1295 END SUBROUTINE land_percentages
1297 SUBROUTINE check_consistency ( ivgtyp , isltyp , landmask , &
1298 ids , ide , jds , jde , kds , kde , &
1299 ims , ime , jms , jme , kms , kme , &
1300 its , ite , jts , jte , kts , kte , &
1301 iswater )
1303 IMPLICIT NONE
1305 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1306 ims , ime , jms , jme , kms , kme , &
1307 its , ite , jts , jte , kts , kte , &
1308 iswater
1309 INTEGER , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: isltyp , ivgtyp
1310 REAL , DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: landmask
1312 LOGICAL :: oops
1313 INTEGER :: oops_count , i , j
1315 oops = .FALSE.
1316 oops_count = 0
1318 DO j = jts, MIN(jde-1,jte)
1319 DO i = its, MIN(ide-1,ite)
1320 IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater ) ) .OR. &
1321 ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater ) ) ) THEN
1322 print *,'mismatch in landmask and veg type'
1323 print *,'i,j=',i,j, ' landmask =',NINT(landmask(i,j)),' ivgtyp=',ivgtyp(i,j)
1324 oops = .TRUE.
1325 oops_count = oops_count + 1
1326 landmask(i,j) = 0
1327 ivgtyp(i,j)=16
1328 isltyp(i,j)=14
1329 END IF
1330 END DO
1331 END DO
1333 IF ( oops ) THEN
1334 CALL wrf_debug( 0, 'mismatch in check_consistency, turned to water points, be careful' )
1335 END IF
1337 END SUBROUTINE check_consistency
1339 SUBROUTINE check_consistency2( ivgtyp , isltyp , landmask , &
1340 tmn , tsk , sst , xland , &
1341 tslb , smois , sh2o , &
1342 num_soil_layers , id , &
1343 ids , ide , jds , jde , kds , kde , &
1344 ims , ime , jms , jme , kms , kme , &
1345 its , ite , jts , jte , kts , kte , &
1346 iswater )
1348 USE module_configure
1349 USE module_optional_input
1351 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
1352 ims , ime , jms , jme , kms , kme , &
1353 its , ite , jts , jte , kts , kte
1354 INTEGER , INTENT(IN) :: num_soil_layers , id
1356 INTEGER , DIMENSION(ims:ime,jms:jme) :: ivgtyp , isltyp
1357 REAL , DIMENSION(ims:ime,jms:jme) :: landmask , tmn , tsk , sst , xland
1358 REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) :: tslb , smois , sh2o
1360 INTEGER :: oops1 , oops2
1361 INTEGER :: i , j , k
1363 fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(id) )
1365 CASE ( SLABSCHEME , LSMSCHEME , RUCLSMSCHEME )
1366 DO j = jts, MIN(jde-1,jte)
1367 DO i = its, MIN(ide-1,ite)
1368 IF ( ( landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
1369 tmn(i,j) = sst(i,j)
1370 tsk(i,j) = sst(i,j)
1371 ELSE IF ( landmask(i,j) .LT. 0.5 ) THEN
1372 tmn(i,j) = tsk(i,j)
1373 END IF
1374 END DO
1375 END DO
1376 END SELECT fix_tsk_tmn
1378 ! Is the TSK reasonable?
1380 DO j = jts, MIN(jde-1,jte)
1381 DO i = its, MIN(ide-1,ite)
1382 IF ( tsk(i,j) .LT. 170 .or. tsk(i,j) .GT. 400. ) THEN
1383 print *,'error in the TSK'
1384 print *,'i,j=',i,j
1385 print *,'landmask=',landmask(i,j)
1386 print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1387 if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
1388 tsk(i,j)=tmn(i,j)
1389 else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1390 tsk(i,j)=sst(i,j)
1391 else
1392 CALL wrf_error_fatal ( 'TSK unreasonable' )
1393 end if
1394 END IF
1395 END DO
1396 END DO
1398 ! Is the TMN reasonable?
1400 DO j = jts, MIN(jde-1,jte)
1401 DO i = its, MIN(ide-1,ite)
1402 IF ( ( ( tmn(i,j) .LT. 170. ) .OR. ( tmn(i,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
1403 print *,'error in the TMN'
1404 print *,'i,j=',i,j
1405 print *,'landmask=',landmask(i,j)
1406 print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1407 if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
1408 tmn(i,j)=tsk(i,j)
1409 else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1410 tmn(i,j)=sst(i,j)
1411 else
1412 CALL wrf_error_fatal ( 'TMN unreasonable' )
1413 endif
1414 END IF
1415 END DO
1416 END DO
1418 ! Is the TSLB reasonable?
1420 DO j = jts, MIN(jde-1,jte)
1421 DO i = its, MIN(ide-1,ite)
1422 IF ( ( ( tslb(i,1,j) .LT. 170. ) .OR. ( tslb(i,1,j) .GT. 400. ) ) .AND. ( landmask(i,j) .GT. 0.5 ) ) THEN
1423 print *,'error in the TSLB'
1424 print *,'i,j=',i,j
1425 print *,'landmask=',landmask(i,j)
1426 print *,'tsk, sst, tmn=',tsk(i,j),sst(i,j),tmn(i,j)
1427 print *,'tslb = ',tslb(i,:,j)
1428 print *,'old smois = ',smois(i,:,j)
1429 DO l = 1 , num_soil_layers
1430 sh2o(i,l,j) = 0.0
1431 END DO
1432 DO l = 1 , num_soil_layers
1433 smois(i,l,j) = 0.3
1434 END DO
1435 if(tsk(i,j).gt.170. .and. tsk(i,j).lt.400.)then
1436 DO l = 1 , num_soil_layers
1437 tslb(i,l,j)=tsk(i,j)
1438 END DO
1439 else if(sst(i,j).gt.170. .and. sst(i,j).lt.400.)then
1440 DO l = 1 , num_soil_layers
1441 tslb(i,l,j)=sst(i,j)
1442 END DO
1443 else if(tmn(i,j).gt.170. .and. tmn(i,j).lt.400.)then
1444 DO l = 1 , num_soil_layers
1445 tslb(i,l,j)=tmn(i,j)
1446 END DO
1447 else
1448 CALL wrf_error_fatal ( 'TSLB unreasonable' )
1449 endif
1450 END IF
1451 END DO
1452 END DO
1454 ! Let us make sure (again) that the landmask and the veg/soil categories match.
1456 oops1=0
1457 oops2=0
1458 DO j = jts, MIN(jde-1,jte)
1459 DO i = its, MIN(ide-1,ite)
1460 IF ( ( ( landmask(i,j) .LT. 0.5 ) .AND. ( ivgtyp(i,j) .NE. iswater .OR. isltyp(i,j) .NE. 14 ) ) .OR. &
1461 ( ( landmask(i,j) .GT. 0.5 ) .AND. ( ivgtyp(i,j) .EQ. iswater .OR. isltyp(i,j) .EQ. 14 ) ) ) THEN
1462 IF ( tslb(i,1,j) .GT. 1. ) THEN
1463 oops1=oops1+1
1464 ivgtyp(i,j) = 5
1465 isltyp(i,j) = 8
1466 landmask(i,j) = 1
1467 xland(i,j) = 1
1468 ELSE IF ( sst(i,j) .GT. 1. ) THEN
1469 oops2=oops2+1
1470 ivgtyp(i,j) = iswater
1471 isltyp(i,j) = 14
1472 landmask(i,j) = 0
1473 xland(i,j) = 2
1474 ELSE
1475 print *,'the landmask and soil/veg cats do not match'
1476 print *,'i,j=',i,j
1477 print *,'landmask=',landmask(i,j)
1478 print *,'ivgtyp=',ivgtyp(i,j)
1479 print *,'isltyp=',isltyp(i,j)
1480 print *,'iswater=', iswater
1481 print *,'tslb=',tslb(i,:,j)
1482 print *,'sst=',sst(i,j)
1483 CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' )
1484 END IF
1485 END IF
1486 END DO
1487 END DO
1488 if (oops1.gt.0) then
1489 print *,'points artificially set to land : ',oops1
1490 endif
1491 if(oops2.gt.0) then
1492 print *,'points artificially set to water: ',oops2
1493 endif
1495 END SUBROUTINE check_consistency2
1496 !!!!!!!!!!!!!!!!!!!!!!!!!!!11
1497 SUBROUTINE vert_cor(parent,znw_c,k_dim_c)
1498 USE module_domain
1499 IMPLICIT NONE
1500 TYPE(domain), POINTER :: parent
1501 integer , intent(in) :: k_dim_c
1502 real , dimension(k_dim_c), INTENT(IN) :: znw_c
1504 integer :: kde_c , kde_n ,n_refine,ii,kkk,k
1505 real :: dznw_m,cof1,cof2
1507 kde_c = k_dim_c
1508 kde_n = parent%e_vert
1509 n_refine = parent % vert_refine_fact
1512 kkk = 0
1513 do k = 1 , kde_c-1
1514 dznw_m = znw_c(k+1) - znw_c(k)
1515 do ii = 1,n_refine
1516 kkk = kkk + 1
1517 parent%znw(kkk) = znw_c(k) + float(ii-1)/float(n_refine)*dznw_m
1518 enddo
1519 enddo
1520 parent%znw(kde_n) = znw_c(kde_c)
1521 parent%znw(1) = znw_c(1)
1523 DO k=1, kde_n-1
1524 parent%dnw(k) = parent%znw(k+1) - parent%znw(k)
1525 parent%rdnw(k) = 1./parent%dnw(k)
1526 parent%znu(k) = 0.5*(parent%znw(k+1)+parent%znw(k))
1527 END DO
1529 DO k=2, kde_n-1
1530 parent%dn(k) = 0.5*(parent%dnw(k)+parent%dnw(k-1))
1531 parent%rdn(k) = 1./parent%dn(k)
1532 parent%fnp(k) = .5* parent%dnw(k )/parent%dn(k)
1533 parent%fnm(k) = .5* parent%dnw(k-1)/parent%dn(k)
1534 END DO
1536 cof1 = (2.*parent%dn(2)+parent%dn(3))/(parent%dn(2)+parent%dn(3))*parent%dnw(1)/parent%dn(2)
1537 cof2 = parent%dn(2) /(parent%dn(2)+parent%dn(3))*parent%dnw(1)/parent%dn(3)
1539 parent%cf1 = parent%fnp(2) + cof1
1540 parent%cf2 = parent%fnm(2) - cof1 - cof2
1541 parent%cf3 = cof2
1543 parent%cfn = (.5*parent%dnw(kde_n-1)+parent%dn(kde_n-1))/parent%dn(kde_n-1)
1544 parent%cfn1 = -.5*parent%dnw(kde_n-1)/parent%dn(kde_n-1)
1548 END SUBROUTINE vert_cor
1551 SUBROUTINE init_domain_constants_em_ptr ( parent , nest )
1552 USE module_domain
1553 USE module_configure
1554 IMPLICIT NONE
1555 TYPE(domain), POINTER :: parent , nest
1556 INTERFACE
1557 SUBROUTINE init_domain_constants_em ( parent , nest )
1558 USE module_domain
1559 USE module_configure
1560 TYPE(domain) :: parent , nest
1561 END SUBROUTINE init_domain_constants_em
1562 END INTERFACE
1563 CALL init_domain_constants_em ( parent , nest )
1564 END SUBROUTINE init_domain_constants_em_ptr
1567 SUBROUTINE vertical_interp (parent_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c)
1568 USE module_domain
1569 USE module_configure
1570 IMPLICIT NONE
1571 TYPE(domain), POINTER :: parent_grid
1572 INTEGER , INTENT (IN) :: k_dim_c
1573 REAL , INTENT (IN) :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c
1574 REAL , DIMENSION(k_dim_c) , INTENT (IN) :: znw_c,znu_c
1576 integer :: kde_c , kde_n ,n_refine,ii,kkk
1577 integer :: i , j, k , itrace
1578 real :: p_top_m , p_surf_m , mu_m , hsca_m , pre_c ,pre_n
1580 real, allocatable, dimension(:) :: alt_w_c , alt_u_c ,pro_w_c , pro_u_c
1581 real, allocatable, dimension(:) :: alt_w_n , alt_u_n ,pro_w_n , pro_u_n
1583 INTEGER :: nids, nide, njds, njde, nkds, nkde, &
1584 nims, nime, njms, njme, nkms, nkme, &
1585 nips, nipe, njps, njpe, nkps, nkpe
1588 hsca_m = 6.7
1589 n_refine = model_config_rec % vert_refine_fact
1590 kde_c = k_dim_c
1591 kde_n = parent_grid%e_vert
1593 CALL get_ijk_from_grid ( parent_grid , &
1594 nids, nide, njds, njde, nkds, nkde, &
1595 nims, nime, njms, njme, nkms, nkme, &
1596 nips, nipe, njps, njpe, nkps, nkpe )
1598 print * , 'MOUSTA_VER ',parent_grid%e_vert , kde_c , kde_n
1599 print *, nids , nide , njds , njde , nkds , nkde
1600 print *, nims , nime , njms , njme , nkms , nkme
1601 print *, nips , nipe , njps , njpe , nkps , nkpe
1605 allocate (alt_w_c(kde_c))
1606 allocate (alt_u_c(kde_c+1))
1607 allocate (pro_w_c(kde_c))
1608 allocate (pro_u_c(kde_c+1))
1610 allocate (alt_w_n(kde_n))
1611 allocate (alt_u_n(kde_n+1))
1612 allocate (pro_w_n(kde_n))
1613 allocate (pro_u_n(kde_n+1))
1615 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11111
1616 p_top_m = parent_grid%p_top
1617 p_surf_m = 1.e5
1618 mu_m = p_surf_m - p_top_m
1619 print * , 'p_top_m', p_top_m
1620 ! parent
1621 do k = 1,kde_c
1622 pre_c = mu_m * znw_c(k) + p_top_m
1623 alt_w_c(k) = -hsca_m * alog(pre_c/p_surf_m)
1624 enddo
1625 do k = 1,kde_c-1
1626 pre_c = mu_m * znu_c(k) + p_top_m
1627 alt_u_c(k+1) = -hsca_m * alog(pre_c/p_surf_m)
1628 enddo
1629 alt_u_c(1) = alt_w_c(1)
1630 alt_u_c(kde_c+1) = alt_w_c(kde_c)
1631 ! nest
1632 do k = 1,kde_n
1633 pre_n = mu_m * parent_grid%znw(k) + p_top_m
1634 alt_w_n(k) = -hsca_m * alog(pre_n/p_surf_m)
1635 enddo
1636 do k = 1,kde_n-1
1637 pre_n = mu_m * parent_grid%znu(k) + p_top_m
1638 alt_u_n(k+1) = -hsca_m * alog(pre_n/p_surf_m)
1639 enddo
1640 alt_u_n(1) = alt_w_n(1)
1641 alt_u_n(kde_n+1) = alt_w_n(kde_n)
1642 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1644 IF ( SIZE( parent_grid%u_2, 1 ) * SIZE( parent_grid%u_2, 3 ) .GT. 1 ) THEN
1645 do j = njms , njme
1646 do i = nims , nime
1648 do k = 1,kde_c-1
1649 pro_u_c(k+1) = parent_grid%u_2(i,k,j)
1650 enddo
1651 pro_u_c(1 ) = cf1_c*parent_grid%u_2(i,1,j) &
1652 + cf2_c*parent_grid%u_2(i,2,j) &
1653 + cf3_c*parent_grid%u_2(i,3,j)
1655 pro_u_c(kde_c+1) = cfn_c *parent_grid%u_2(i,kde_c-1,j) &
1656 + cfn1_c*parent_grid%u_2(i,kde_c-2,j)
1658 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1660 do k = 1,kde_n-1
1661 parent_grid%u_2(i,k,j) = pro_u_n(k+1)
1662 enddo
1664 enddo
1665 enddo
1666 ENDIF
1668 IF ( SIZE( parent_grid%v_2, 1 ) * SIZE( parent_grid%v_2, 3 ) .GT. 1 ) THEN
1669 do j = njms , njme
1670 do i = nims , nime
1672 do k = 1,kde_c-1
1673 pro_u_c(k+1) = parent_grid%v_2(i,k,j)
1674 enddo
1675 pro_u_c(1 ) = cf1_c*parent_grid%v_2(i,1,j) &
1676 + cf2_c*parent_grid%v_2(i,2,j) &
1677 + cf3_c*parent_grid%v_2(i,3,j)
1679 pro_u_c(kde_c+1) = cfn_c *parent_grid%v_2(i,kde_c-1,j) &
1680 + cfn1_c*parent_grid%v_2(i,kde_c-2,j)
1682 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1684 do k = 1,kde_n-1
1685 parent_grid%v_2(i,k,j) = pro_u_n(k+1)
1686 enddo
1688 enddo
1689 enddo
1690 ENDIF
1692 IF ( SIZE( parent_grid%w_2, 1 ) * SIZE( parent_grid%w_2, 3 ) .GT. 1 ) THEN
1693 do j = njms , njme
1694 do i = nims , nime
1696 do k = 1,kde_c
1697 pro_w_c(k) = parent_grid%w_2(i,k,j)
1698 enddo
1699 call inter(pro_w_c,alt_w_c,kde_c,pro_w_n,alt_w_n,kde_n)
1701 do k = 1,kde_n
1702 parent_grid%w_2(i,k,j) = pro_w_n(k)
1703 enddo
1704 enddo
1705 enddo
1706 ENDIF
1708 IF ( SIZE( parent_grid%t_2, 1 ) * SIZE( parent_grid%t_2, 3 ) .GT. 1 ) THEN
1709 do j = njms , njme
1710 do i = nims , nime
1712 do k = 1,kde_c-1
1713 pro_u_c(k+1) = parent_grid%t_2(i,k,j)
1714 enddo
1715 pro_u_c(1 ) = cf1_c*parent_grid%t_2(i,1,j) &
1716 + cf2_c*parent_grid%t_2(i,2,j) &
1717 + cf3_c*parent_grid%t_2(i,3,j)
1719 pro_u_c(kde_c+1) = cfn_c *parent_grid%t_2(i,kde_c-1,j) &
1720 + cfn1_c*parent_grid%t_2(i,kde_c-2,j)
1722 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1724 do k = 1,kde_n-1
1725 parent_grid%t_2(i,k,j) = pro_u_n(k+1)
1726 enddo
1728 enddo
1729 enddo
1730 ENDIF
1732 DO itrace = PARAM_FIRST_SCALAR, num_moist
1733 IF ( SIZE( parent_grid%moist, 1 ) * SIZE( parent_grid%moist, 3 ) .GT. 1 ) THEN
1734 do j = njms , njme
1735 do i = nims , nime
1737 do k = 1,kde_c-1
1738 pro_u_c(k+1) = parent_grid%moist(i,k,j,itrace)
1739 enddo
1740 pro_u_c(1 ) = cf1_c*parent_grid%moist(i,1,j,itrace) &
1741 + cf2_c*parent_grid%moist(i,2,j,itrace) &
1742 + cf3_c*parent_grid%moist(i,3,j,itrace)
1744 pro_u_c(kde_c+1) = cfn_c *parent_grid%moist(i,kde_c-1,j,itrace) &
1745 + cfn1_c*parent_grid%moist(i,kde_c-2,j,itrace)
1747 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1749 do k = 1,kde_n-1
1750 parent_grid%moist(i,k,j,itrace) = pro_u_n(k+1)
1751 enddo
1753 enddo
1754 enddo
1755 ENDIF
1756 ENDDO
1758 DO itrace = PARAM_FIRST_SCALAR, num_dfi_moist
1759 IF ( SIZE( parent_grid%dfi_moist, 1 ) * SIZE( parent_grid%dfi_moist, 3 ) .GT. 1 ) THEN
1760 do j = njms , njme
1761 do i = nims , nime
1763 do k = 1,kde_c-1
1764 pro_u_c(k+1) = parent_grid%dfi_moist(i,k,j,itrace)
1765 enddo
1766 pro_u_c(1 ) = cf1_c*parent_grid%dfi_moist(i,1,j,itrace) &
1767 + cf2_c*parent_grid%dfi_moist(i,2,j,itrace) &
1768 + cf3_c*parent_grid%dfi_moist(i,3,j,itrace)
1770 pro_u_c(kde_c+1) = cfn_c *parent_grid%dfi_moist(i,kde_c-1,j,itrace) &
1771 + cfn1_c*parent_grid%dfi_moist(i,kde_c-2,j,itrace)
1773 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1775 do k = 1,kde_n-1
1776 parent_grid%dfi_moist(i,k,j,itrace) = pro_u_n(k+1)
1777 enddo
1779 enddo
1780 enddo
1781 ENDIF
1782 ENDDO
1784 DO itrace = PARAM_FIRST_SCALAR, num_scalar
1785 IF ( SIZE( parent_grid%scalar, 1 ) * SIZE( parent_grid%scalar, 3 ) .GT. 1 ) THEN
1786 do j = njms , njme
1787 do i = nims , nime
1789 do k = 1,kde_c-1
1790 pro_u_c(k+1) = parent_grid%scalar(i,k,j,itrace)
1791 enddo
1792 pro_u_c(1 ) = cf1_c*parent_grid%scalar(i,1,j,itrace) &
1793 + cf2_c*parent_grid%scalar(i,2,j,itrace) &
1794 + cf3_c*parent_grid%scalar(i,3,j,itrace)
1796 pro_u_c(kde_c+1) = cfn_c *parent_grid%scalar(i,kde_c-1,j,itrace) &
1797 + cfn1_c*parent_grid%scalar(i,kde_c-2,j,itrace)
1799 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1801 do k = 1,kde_n-1
1802 parent_grid%scalar(i,k,j,itrace) = pro_u_n(k+1)
1803 enddo
1805 enddo
1806 enddo
1807 ENDIF
1808 ENDDO
1810 DO itrace = PARAM_FIRST_SCALAR, num_dfi_scalar
1811 IF ( SIZE( parent_grid%dfi_scalar, 1 ) * SIZE( parent_grid%dfi_scalar, 3 ) .GT. 1 ) THEN
1812 do j = njms , njme
1813 do i = nims , nime
1815 do k = 1,kde_c-1
1816 pro_u_c(k+1) = parent_grid%dfi_scalar(i,k,j,itrace)
1817 enddo
1818 pro_u_c(1 ) = cf1_c*parent_grid%dfi_scalar(i,1,j,itrace) &
1819 + cf2_c*parent_grid%dfi_scalar(i,2,j,itrace) &
1820 + cf3_c*parent_grid%dfi_scalar(i,3,j,itrace)
1822 pro_u_c(kde_c+1) = cfn_c *parent_grid%dfi_scalar(i,kde_c-1,j,itrace) &
1823 + cfn1_c*parent_grid%dfi_scalar(i,kde_c-2,j,itrace)
1825 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1827 do k = 1,kde_n-1
1828 parent_grid%dfi_scalar(i,k,j,itrace) = pro_u_n(k+1)
1829 enddo
1831 enddo
1832 enddo
1833 ENDIF
1834 ENDDO
1838 IF ( SIZE( parent_grid%f_ice_phy, 1 ) * SIZE( parent_grid%f_ice_phy, 3 ) .GT. 1 ) THEN
1839 do j = njms , njme
1840 do i = nims , nime
1842 do k = 1,kde_c-1
1843 pro_u_c(k+1) = parent_grid%f_ice_phy(i,k,j)
1844 enddo
1845 pro_u_c(1 ) = cf1_c*parent_grid%f_ice_phy(i,1,j) &
1846 + cf2_c*parent_grid%f_ice_phy(i,2,j) &
1847 + cf3_c*parent_grid%f_ice_phy(i,3,j)
1849 pro_u_c(kde_c+1) = cfn_c *parent_grid%f_ice_phy(i,kde_c-1,j) &
1850 + cfn1_c*parent_grid%f_ice_phy(i,kde_c-2,j)
1852 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1854 do k = 1,kde_n-1
1855 parent_grid%f_ice_phy(i,k,j) = pro_u_n(k+1)
1856 enddo
1858 enddo
1859 enddo
1860 ENDIF
1862 IF ( SIZE( parent_grid%f_rain_phy, 1 ) * SIZE( parent_grid%f_rain_phy, 3 ) .GT. 1 ) THEN
1863 do j = njms , njme
1864 do i = nims , nime
1866 do k = 1,kde_c-1
1867 pro_u_c(k+1) = parent_grid%f_rain_phy(i,k,j)
1868 enddo
1869 pro_u_c(1 ) = cf1_c*parent_grid%f_rain_phy(i,1,j) &
1870 + cf2_c*parent_grid%f_rain_phy(i,2,j) &
1871 + cf3_c*parent_grid%f_rain_phy(i,3,j)
1873 pro_u_c(kde_c+1) = cfn_c *parent_grid%f_rain_phy(i,kde_c-1,j) &
1874 + cfn1_c*parent_grid%f_rain_phy(i,kde_c-2,j)
1876 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1878 do k = 1,kde_n-1
1879 parent_grid%f_rain_phy(i,k,j) = pro_u_n(k+1)
1880 enddo
1882 enddo
1883 enddo
1884 ENDIF
1887 IF ( SIZE( parent_grid%f_rimef_phy, 1 ) * SIZE( parent_grid%f_rimef_phy, 3 ) .GT. 1 ) THEN
1888 do j = njms , njme
1889 do i = nims , nime
1891 do k = 1,kde_c-1
1892 pro_u_c(k+1) = parent_grid%f_rimef_phy(i,k,j)
1893 enddo
1894 pro_u_c(1 ) = cf1_c*parent_grid%f_rimef_phy(i,1,j) &
1895 + cf2_c*parent_grid%f_rimef_phy(i,2,j) &
1896 + cf3_c*parent_grid%f_rimef_phy(i,3,j)
1898 pro_u_c(kde_c+1) = cfn_c *parent_grid%f_rimef_phy(i,kde_c-1,j) &
1899 + cfn1_c*parent_grid%f_rimef_phy(i,kde_c-2,j)
1901 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1903 do k = 1,kde_n-1
1904 parent_grid%f_rimef_phy(i,k,j) = pro_u_n(k+1)
1905 enddo
1907 enddo
1908 enddo
1909 ENDIF
1911 IF ( SIZE( parent_grid%h_diabatic, 1 ) * SIZE( parent_grid%h_diabatic, 3 ) .GT. 1 ) THEN
1912 do j = njms , njme
1913 do i = nims , nime
1915 do k = 1,kde_c-1
1916 pro_u_c(k+1) = parent_grid%h_diabatic(i,k,j)
1917 enddo
1918 pro_u_c(1 ) = cf1_c*parent_grid%h_diabatic(i,1,j) &
1919 + cf2_c*parent_grid%h_diabatic(i,2,j) &
1920 + cf3_c*parent_grid%h_diabatic(i,3,j)
1922 pro_u_c(kde_c+1) = cfn_c *parent_grid%h_diabatic(i,kde_c-1,j) &
1923 + cfn1_c*parent_grid%h_diabatic(i,kde_c-2,j)
1925 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1927 do k = 1,kde_n-1
1928 parent_grid%h_diabatic(i,k,j) = pro_u_n(k+1)
1929 enddo
1931 enddo
1932 enddo
1933 ENDIF
1935 IF ( SIZE( parent_grid%rthraten, 1 ) * SIZE( parent_grid%rthraten, 3 ) .GT. 1 ) THEN
1936 do j = njms , njme
1937 do i = nims , nime
1939 do k = 1,kde_c-1
1940 pro_u_c(k+1) = parent_grid%rthraten(i,k,j)
1941 enddo
1942 pro_u_c(1 ) = cf1_c*parent_grid%rthraten(i,1,j) &
1943 + cf2_c*parent_grid%rthraten(i,2,j) &
1944 + cf3_c*parent_grid%rthraten(i,3,j)
1946 pro_u_c(kde_c+1) = cfn_c *parent_grid%rthraten(i,kde_c-1,j) &
1947 + cfn1_c*parent_grid%rthraten(i,kde_c-2,j)
1949 call inter(pro_u_c,alt_u_c,kde_c+1,pro_u_n,alt_u_n,kde_n+1)
1951 do k = 1,kde_n-1
1952 parent_grid%rthraten(i,k,j) = pro_u_n(k+1)
1953 enddo
1955 enddo
1956 enddo
1957 ENDIF
1967 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1968 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1969 deallocate (alt_w_c)
1970 deallocate (alt_u_c)
1971 deallocate (pro_w_c)
1972 deallocate (pro_u_c)
1974 deallocate (alt_w_n)
1975 deallocate (alt_u_n)
1976 deallocate (pro_w_n)
1977 deallocate (pro_u_n)
1980 END SUBROUTINE vertical_interp
1982 !!!!!!!!!!!!!!!!!!!!!!!!11
1983 SUBROUTINE inter(pro_c,alt_c,kde_c,pro_n,alt_n,kde_n)
1985 IMPLICIT NONE
1986 INTEGER , INTENT(IN) :: kde_c,kde_n
1987 REAL , DIMENSION(kde_c) , INTENT(IN ) :: pro_c,alt_c
1988 REAL , DIMENSION(kde_n) , INTENT(IN ) :: alt_n
1989 REAL , DIMENSION(kde_n) , INTENT(OUT) :: pro_n
1991 real ,dimension(kde_c) :: a,b,c,d
1992 real :: p
1993 integer :: i,j
1996 call coeff_mon(alt_c,pro_c,a,b,c,d,kde_c)
1998 do i = 1,kde_n-1
2000 do j=1,kde_c-1
2002 if ( (alt_n(i) .ge. alt_c(j)).and.(alt_n(i) .lt. alt_c(j+1)) ) then
2003 p = alt_n(i)-alt_c(j)
2004 pro_n(i) = p*( p*(a(j)*p+b(j))+c(j)) + d(j)
2005 goto 20
2006 endif
2007 enddo
2008 20 continue
2009 enddo
2011 pro_n(kde_n) = pro_c(kde_c)
2014 END SUBROUTINE inter
2016 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11
2018 subroutine coeff_mon(x,y,a,b,c,d,n)
2020 implicit none
2022 integer :: n
2023 real ,dimension(n) :: x,y,a,b,c,d
2024 real ,dimension(n) :: h,s,p,yp
2026 integer :: i
2029 do i=1,n-1
2030 h(i) = (x(i+1)-x(i))
2031 s(i) = (y(i+1)-y(i)) / h(i)
2032 enddo
2034 do i=2,n-1
2035 p(i) = (s(i-1)*h(i)+s(i)*h(i-1)) / (h(i-1)+h(i))
2036 enddo
2038 p(1) = s(1)
2039 p(n) = s(n-1)
2041 do i=1,n
2042 yp(i) = p(i)
2043 enddo
2044 !!!!!!!!!!!!!!!!!!!!!
2046 do i=2,n-1
2047 yp(i) = (sign(1.,s(i-1))+sign(1.,s(i)))* min( abs(s(i-1)),abs(s(i)),0.5*abs(p(i)))
2048 enddo
2050 do i = 1,n-1
2051 a(i) = (yp(i)+yp(i+1)-2.*s(i))/(h(i)*h(i))
2052 b(i) = (3.*s(i)-2.*yp(i)-yp(i+1))/h(i)
2053 c(i) = yp(i)
2054 d(i) = y(i)
2055 enddo
2057 end subroutine coeff_mon