| blob | 96629232bf7b0ba29bbaaa466a5c163134980941 |
1 !REAL:MODEL_LAYER:INITIALIZATION
3 #ifndef VERT_UNIT
4 ! This MODULE holds the routines which are used to perform various initializations
5 ! for the individual domains, specifically for the Eulerian, mass-based coordinate.
7 !-----------------------------------------------------------------------
9 MODULE module_initialize_real
11 USE module_bc
12 USE module_configure
13 USE module_domain
14 USE module_io_domain
15 USE module_model_constants
16 USE module_state_description
17 USE module_timing
18 USE module_soil_pre
19 USE module_date_time
20 USE module_llxy
21 USE module_polarfft
22 #ifdef DM_PARALLEL
23 USE module_dm
24 USE module_comm_dm, ONLY : &
25 HALO_EM_INIT_1_sub &
26 ,HALO_EM_INIT_2_sub &
27 ,HALO_EM_INIT_3_sub &
28 ,HALO_EM_INIT_4_sub &
29 ,HALO_EM_INIT_5_sub &
30 ,HALO_EM_INIT_6_sub &
31 ,HALO_EM_VINTERP_UV_1_sub
32 #endif
34 REAL , SAVE :: p_top_save
35 INTEGER :: internal_time_loop
37 CONTAINS
39 !-------------------------------------------------------------------
41 SUBROUTINE init_domain ( grid )
43 IMPLICIT NONE
45 ! Input space and data. No gridded meteorological data has been stored, though.
47 ! TYPE (domain), POINTER :: grid
48 TYPE (domain) :: grid
50 ! Local data.
52 INTEGER :: idum1, idum2
54 CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 )
56 CALL init_domain_rk( grid &
57 !
58 #include "actual_new_args.inc"
59 !
60 )
61 END SUBROUTINE init_domain
63 !-------------------------------------------------------------------
65 SUBROUTINE init_domain_rk ( grid &
66 !
67 #include "dummy_new_args.inc"
68 !
69 )
71 USE module_optional_input
72 USE module_radiation_driver, ONLY: cal_cldfra3
73 USE module_dm, ONLY : wrf_dm_max_real
74 use module_madwrf, only : Init_madwrf_clouds, Init_madwrf_tracers
76 IMPLICIT NONE
78 ! Input space and data. No gridded meteorological data has been stored, though.
80 ! TYPE (domain), POINTER :: grid
81 TYPE (domain) :: grid
83 #include "dummy_new_decl.inc"
85 TYPE (grid_config_rec_type) :: config_flags
87 ! Local domain indices and counters.
89 INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
90 INTEGER :: loop , num_seaice_changes
92 INTEGER :: ids, ide, jds, jde, kds, kde, &
93 ims, ime, jms, jme, kms, kme, &
94 its, ite, jts, jte, kts, kte, &
95 ips, ipe, jps, jpe, kps, kpe, &
96 i, j, k, kk
98 INTEGER :: imsx, imex, jmsx, jmex, kmsx, kmex, &
99 ipsx, ipex, jpsx, jpex, kpsx, kpex, &
100 imsy, imey, jmsy, jmey, kmsy, kmey, &
101 ipsy, ipey, jpsy, jpey, kpsy, kpey
103 INTEGER :: ns
105 ! Local data
107 INTEGER :: error
108 INTEGER :: im, num_3d_m, num_3d_s
109 REAL :: B1, B2, B3, B4, B5
110 REAL :: p_surf, p_level
111 REAL :: cof1, cof2
112 REAL :: qvf , qvf1 , qvf2 , qtot, pd_surf
113 REAL :: p00 , t00 , a , tiso, p_strat, a_strat
114 REAL :: hold_znw , ptemp
115 REAL :: vap_pres_mb , sat_vap_pres_mb
116 LOGICAL :: were_bad
118 LOGICAL :: stretch_grid, dry_sounding, debug
119 INTEGER :: IICOUNT, icount
121 REAL :: p_top_requested , temp
122 INTEGER :: num_metgrid_levels
123 INTEGER, PARAMETER :: num_wif_levels_default = 30
124 INTEGER :: aer_init_opt
125 REAL , DIMENSION(max_eta) :: eta_levels
127 INTEGER :: auto_levels_opt
128 REAL :: max_dz, dzbot, dzstretch_s, dzstretch_u, z1
130 INTEGER:: i_end, j_end
131 REAL, ALLOCATABLE, DIMENSION(:):: temp_P, temp_T, temp_R, temp_Dz
132 REAL, ALLOCATABLE, DIMENSION(:):: temp_Qv, temp_Qc, temp_Qi, temp_Qs
133 REAL, ALLOCATABLE, DIMENSION(:):: temp_CF, temp_Nc, temp_Ni
134 REAL:: max_relh, temp_xland, gridkm
135 LOGICAL :: debug_flag = .FALSE.
137 REAL :: dclat
139 ! INTEGER , PARAMETER :: nl_max = 1000
140 ! REAL , DIMENSION(nl_max) :: grid%dn
142 integer::oops1,oops2
144 REAL :: zap_close_levels
145 INTEGER :: force_sfc_in_vinterp
146 INTEGER :: interp_type , lagrange_order , extrap_type , t_extrap_type
147 INTEGER :: linear_interp
148 LOGICAL :: lowest_lev_from_sfc , use_levels_below_ground , use_surface
149 LOGICAL :: we_have_tavgsfc , we_have_tsk
151 INTEGER :: lev500 , loop_count
152 REAL :: zl , zu , pl , pu , z500 , dz500 , tvsfc , dpmu
153 REAL :: pfu, pfd, phm
155 LOGICAL , PARAMETER :: want_full_levels = .TRUE.
156 LOGICAL , PARAMETER :: want_half_levels = .FALSE.
158 CHARACTER (LEN=256) :: a_message, mminlu
159 REAL :: max_mf
161 ! Excluded middle.
163 LOGICAL :: any_valid_points
164 INTEGER :: i_valid , j_valid
166 ! Vert interpolation in WRF
168 INTEGER :: k_max_p , k_min_p
170 !-- Carsel and Parrish [1988]
171 REAL , DIMENSION(100) :: lqmi
173 REAL , DIMENSION(100) :: thickness , levels
174 REAL :: t_start , t_end
175 REAL , ALLOCATABLE , DIMENSION(:,:) :: clat_glob
177 ! added for multiple specified sets of eta_levels with vertical grid nesting
178 INTEGER :: ks, ke, id
179 LOGICAL :: vnest !T if using vertical nesting with vet_refine_method=2, otherwise F
181 INTEGER :: j_save
182 INTEGER :: change_soil, change_soilw, iforce
184 REAL:: temp_rho
186 LOGICAL :: wif_upside_down = .FALSE.
188 ! Test on consistency between namelist settings and the available data from geogrid.
190 INTEGER :: geogrid_flag_error
192 ! Vertical pressure checks
194 REAL :: press_above, press_below
196 ! Dimension information stored in grid data structure.
198 CALL cpu_time(t_start)
199 CALL get_ijk_from_grid ( grid , &
200 ids, ide, jds, jde, kds, kde, &
201 ims, ime, jms, jme, kms, kme, &
202 ips, ipe, jps, jpe, kps, kpe, &
203 imsx, imex, jmsx, jmex, kmsx, kmex, &
204 ipsx, ipex, jpsx, jpex, kpsx, kpex, &
205 imsy, imey, jmsy, jmey, kmsy, kmey, &
206 ipsy, ipey, jpsy, jpey, kpsy, kpey )
207 its = ips ; ite = ipe ; jts = jps ; jte = jpe ; kts = kps ; kte = kpe
209 CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
211 ! Check flags from geogrid and the various model settings for any inconsistency.
212 ! The optional data from geogrid mostly started with the v4.0 release. Older
213 ! WPS data could have the required fields. Assume users know what they are
214 ! doing when they bring old data into the newer real program ...
216 IF ( grid%v4_metgrid ) THEN
218 geogrid_flag_error = 0
220 IF ( ( config_flags%topo_wind .EQ. 1 ) .AND. ( flag_var_sso .EQ. 0 ) ) THEN
221 CALL wrf_message ( '----- ERROR: topo_wind = 1 AND flag_var_sso = 0 ' )
222 geogrid_flag_error = geogrid_flag_error + 1
223 END IF
225 IF ( ( config_flags%sf_lake_physics .EQ. 1 ) .AND. ( flag_lake_depth .EQ. 0 ) ) THEN
226 CALL wrf_message ( '----- ERROR: sf_lake_physics = 1 AND flag_lake_depth = 0 ' )
227 geogrid_flag_error = geogrid_flag_error + 1
228 END IF
230 IF ( ( config_flags%sf_surface_physics .EQ. pxlsmscheme ) .AND. ( flag_imperv .EQ. 0 ) ) THEN
231 CALL wrf_message ( '----- ERROR: sf_surface_physics = 7 AND flag_imperv = 0 ' )
232 geogrid_flag_error = geogrid_flag_error + 1
233 END IF
235 IF ( ( config_flags%sf_surface_physics .EQ. pxlsmscheme ) .AND. ( flag_canfra .EQ. 0 ) ) THEN
236 CALL wrf_message ( '----- ERROR: sf_surface_physics = 7 AND flag_canfra = 0 ' )
237 geogrid_flag_error = geogrid_flag_error + 1
238 END IF
240 IF ( ( config_flags%mp_physics .EQ. thompsonaero ) .AND. &
241 ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_erod .EQ. 0 ) ) THEN
242 CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_erod = 0 ' )
243 geogrid_flag_error = geogrid_flag_error + 1
244 END IF
246 IF ( ( config_flags%mp_physics .EQ. thompsonaero ) .AND. &
247 ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_clayfrac .EQ. 0 ) ) THEN
248 CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_clayfrac = 0 ' )
249 geogrid_flag_error = geogrid_flag_error + 1
250 END IF
252 IF ( ( config_flags%mp_physics .EQ. thompsonaero ) .AND. &
253 ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_sandfrac .EQ. 0 ) ) THEN
254 CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_sandfrac = 0 ' )
255 geogrid_flag_error = geogrid_flag_error + 1
256 END IF
258 IF ( geogrid_flag_error .GT. 0 ) THEN
259 CALL wrf_error_fatal ('Either modify the namelist settings, or rebuild the geogrid/metgrid data' )
260 END IF
262 ! Geogrid flags that are not yet used: FLAG_FRC_URB2D FLAG_LAI12M FLAG_URB_PARAM
264 END IF
266 ! Would the user prefer to forego the use of the level of max winds, or the
267 ! tropopause level data? This is an option the user may select. While the
268 ! additional data is able to provide good information (such as a better
269 ! resolution of the jet, a better kink for the tropopause), there are
270 ! horizontal gradients that are introduced. Near a boundary, these gradients
271 ! would be permanent (due to their inclusion in the LBC file). To turn "off"
272 ! the use of the max wind/trop data, set the flags for those levels to zero.
274 flag_pmaxw = 0
275 flag_pmaxwnn = 0
276 flag_ptrop = 0
277 flag_ptropnn = 0
278 IF ( ( config_flags%use_maxw_level .EQ. 0 ) .AND. &
279 ( ( flag_tmaxw .EQ. 1 ) .OR. ( flag_umaxw .EQ. 1 ) .OR. ( flag_vmaxw .EQ. 1 ) .OR. ( flag_hgtmaxw .EQ. 1 ) ) ) THEN
280 flag_tmaxw = 0
281 flag_umaxw = 0
282 flag_vmaxw = 0
283 flag_hgtmaxw = 0
284 CALL wrf_debug ( 0 , 'Turning off use of MAX WIND level data in vertical interpolation' )
285 END IF
286 IF ( ( config_flags%use_trop_level .EQ. 0 ) .AND. &
287 ( ( flag_ttrop .EQ. 1 ) .OR. ( flag_utrop .EQ. 1 ) .OR. ( flag_vtrop .EQ. 1 ) .OR. ( flag_hgttrop .EQ. 1 ) ) ) THEN
288 flag_ttrop = 0
289 flag_utrop = 0
290 flag_vtrop = 0
291 flag_hgttrop = 0
292 CALL wrf_debug ( 0 , 'Turning off use of TROPOPAUSE level data in vertical interpolation' )
293 END IF
295 ! Lake Mask and depth assignment
297 CALL nl_get_iswater ( grid%id , grid%iswater )
298 CALL nl_get_islake ( grid%id , grid%islake )
300 DO j = jts, MIN(jde-1,jte)
301 DO i = its, MIN(ide-1,ite)
302 IF ( grid%lu_index(i,j) .NE. grid%islake ) THEN
303 grid%lakemask(i,j) = 0
304 ELSE
305 grid%lakemask(i,j) = 1
306 END IF
307 END DO
308 END DO
310 IF ( grid%sf_lake_physics .EQ. 1 ) THEN
311 grid%lake_depth_flag = flag_lake_depth
312 IF ( flag_lake_depth .EQ. 0 ) THEN
313 CALL wrf_message ( " Warning: Please rerun WPS to get lake_depth information for lake model" )
315 ! Set lake depth over the ocean to be -3 m, and set the lake depth over land to be -2 m.
317 ELSE
318 DO j = jts, MIN(jde-1,jte)
319 DO i = its, MIN(ide-1,ite)
320 IF ( ( grid%lu_index(i,j) .NE. grid%islake ) .AND. ( grid%lu_index(i,j) .NE. grid%iswater ) ) THEN
321 grid%lake_depth(i,j) = -2
322 ELSE IF ( grid%lu_index(i,j) .NE. grid%islake ) THEN
323 grid%lake_depth(i,j) = -3
324 END IF
325 END DO
326 END DO
327 END IF
328 END IF
330 grid%bathymetry_flag = flag_bathymetry
331 IF ( flag_bathymetry .EQ. 0 ) THEN
332 IF ( grid%shalwater_z0 .EQ. 1 ) THEN
333 CALL wrf_message ( " Warning: No bathymetry data found for shallow water roughness model." )
334 IF ( grid%shalwater_depth .LE. 0.0 ) THEN
335 CALL wrf_message ( " Warning: shalwater_depth must be greater than 0.0 for WRF to run." )
336 END IF
337 END IF
338 DO j = jts, MIN(jde-1,jte)
339 DO i = its, MIN(ide-1,ite)
340 grid%water_depth(i,j) = -4.0
341 END DO
342 END DO
343 ELSE
344 CALL wrf_message ( " Bathymetry dataset from GEBCO Compilation Group. Please acknowledge the following in presentations and publications: GEBCO Compilation Group (2021) GEBCO 2021 Grid (doi:10.5285/c6612cbe-50b3-0cff-e053-6c86abc09f8f)." )
345 DO j = jts, MIN(jde-1,jte)
346 DO i = its, MIN(ide-1,ite)
347 grid%water_depth(i,j) = grid%bathymetry(i,j)
348 ! Get depth of lake based on height of water surface:
349 IF ( grid%lu_index(i,j) .EQ. grid%islake ) THEN
350 grid%water_depth(i,j) = grid%bathymetry(i,j) - grid%ht_gc(i,j)
351 END IF
352 ! Depth is positive:
353 grid%water_depth(i,j) = -grid%water_depth(i,j)
354 ! Set land cells to -10
355 IF ( ( grid%lu_index(i,j) .NE. grid%islake ) .AND. ( grid%lu_index(i,j) .NE. grid%iswater ) ) THEN
356 grid%water_depth(i,j) = -2.0
357 ELSE ! Water cells:
358 ! Find any water cells with negative (originally positive) values...
359 ! ... indicative of mis-match of bathymetry and land mask.
360 IF (grid%water_depth(i,j) .LT. 0.1) THEN
361 grid%water_depth(i,j) = 0.1
362 END IF
363 END IF
364 END DO
365 END DO
366 END IF
368 ! Send out a quick message about the time steps based on the map scale factors.
370 IF ( ( internal_time_loop .EQ. 1 ) .AND. ( grid%id .EQ. 1 ) .AND. &
371 ( .NOT. config_flags%polar ) ) THEN
372 max_mf = grid%msft(its,jts)
373 DO j=jts,MIN(jde-1,jte)
374 DO i=its,MIN(ide-1,ite)
375 max_mf = MAX ( max_mf , grid%msft(i,j) )
376 END DO
377 END DO
378 #if ( defined(DM_PARALLEL) && ! defined(STUBMPI) )
379 max_mf = wrf_dm_max_real ( max_mf )
380 #endif
381 WRITE ( a_message , FMT='(A,F5.2,A)' ) 'Max map factor in domain 1 = ',max_mf, &
382 '. Scale the dt in the model accordingly.'
383 CALL wrf_message ( a_message )
384 END IF
386 ! Check to see if the boundary conditions are set properly in the namelist file.
387 ! This checks for sufficiency and redundancy.
389 CALL boundary_condition_check( config_flags, bdyzone, error, grid%id )
391 ! Some sort of "this is the first time" initialization. Who knows.
393 grid%step_number = 0
394 grid%itimestep=0
396 ! Pull in the info in the namelist to compare it to the input data.
398 grid%real_data_init_type = model_config_rec%real_data_init_type
400 ! To define the base state, we call a USER MODIFIED routine to set the three
401 ! necessary constants: p00 (sea level pressure, Pa), t00 (sea level temperature, K),
402 ! and A (temperature difference, from 1000 mb to 300 mb, K).
404 CALL const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat )
406 ! Save these constants to write out in model output file
408 grid%t00 = t00
409 grid%p00 = p00
410 grid%tlp = a
411 grid%tiso = tiso
412 grid%p_strat = p_strat
413 grid%tlp_strat = a_strat
415 ! Are there any hold-ups to us bypassing the middle of the domain? These
416 ! holdups would be situations where we need data in the middle of the domain.
417 ! FOr example, if this si the first time period, we need the full domain
418 ! processed for ICs. Also, if there is some sort of gridded FDDA turned on, or
419 ! if the SST update is activated, then we can't just blow off the middle of the
420 ! domain all willy-nilly. Other cases of these hold-ups? Sure - what if the
421 ! user wants to smooth the CG topo, we need several rows and columns available.
422 ! What if the lat/lon proj is used, then we need to run a spectral filter on
423 ! the topo. Both are killers when trying to ignore data in the middle of the
424 ! domain.
426 ! If hold_ups = .F., then there are no hold-ups to excluding the middle
427 ! domain processing. If hold_ups = .T., then there are hold-ups, and we
428 ! must process the middle of the domain.
430 hold_ups = ( internal_time_loop .EQ. 1 ) .OR. &
431 ( config_flags%grid_fdda .NE. 0 ) .OR. &
432 ( config_flags%sst_update .EQ. 1 ) .OR. &
433 ( config_flags%qna_update .EQ. 1 ) .OR. &
434 ( config_flags%all_ic_times ) .OR. &
435 ( config_flags%polar )
437 ! There are a few checks that we need to do when the input data comes in with the middle
438 ! excluded by WPS.
440 IF ( flag_excluded_middle .NE. 0 ) THEN
442 ! If this time period of data from WPS has the middle excluded, it had better be OK for
443 ! us to have a hole.
445 IF ( hold_ups ) THEN
446 WRITE ( a_message,* ) 'None of the following are allowed to be TRUE : '
447 CALL wrf_message ( a_message )
448 WRITE ( a_message,* ) ' ( internal_time_loop .EQ. 1 ) ', ( internal_time_loop .EQ. 1 )
449 CALL wrf_message ( a_message )
450 WRITE ( a_message,* ) ' ( config_flags%grid_fdda .NE. 0 ) ', ( config_flags%grid_fdda .NE. 0 )
451 CALL wrf_message ( a_message )
452 WRITE ( a_message,* ) ' ( config_flags%sst_update .EQ. 1 ) ', ( config_flags%sst_update .EQ. 1 )
453 CALL wrf_message ( a_message )
454 WRITE ( a_message,* ) ' ( config_flags%qna_update .EQ. 1 ) ', ( config_flags%qna_update .EQ. 1 )
455 CALL wrf_message ( a_message )
456 WRITE ( a_message,* ) ' ( config_flags%all_ic_times ) ', ( config_flags%all_ic_times )
457 CALL wrf_message ( a_message )
458 WRITE ( a_message,* ) ' ( config_flags%smooth_cg_topo ) ', ( config_flags%smooth_cg_topo )
459 CALL wrf_message ( a_message )
460 WRITE ( a_message,* ) ' ( config_flags%polar ) ', ( config_flags%polar )
461 CALL wrf_message ( a_message )
463 WRITE ( a_message,* ) 'Problems, we cannot have excluded middle data from WPS'
464 CALL wrf_error_fatal ( a_message )
465 END IF
467 ! Make sure that the excluded middle data from metgrid is "wide enough". We only have to check
468 ! when the excluded middle was actually used in WPS.
470 IF ( config_flags%spec_bdy_width .GT. flag_excluded_middle ) THEN
471 WRITE ( a_message,* ) 'The WRF &bdy_control namelist.input spec_bdy_width = ', config_flags%spec_bdy_width
472 CALL wrf_message ( a_message )
473 WRITE ( a_message,* ) 'The WPS &metgrid namelist.wps process_only_bdy width = ',flag_excluded_middle
474 CALL wrf_message ( a_message )
475 WRITE ( a_message,* ) 'WPS process_only_bdy must be >= WRF spec_bdy_width'
476 CALL wrf_error_fatal ( a_message )
477 END IF
478 END IF
479 em_width = config_flags%spec_bdy_width
481 ! We need to find if there are any valid non-excluded-middle points in this
482 ! tile. If so, then we need to hang on to a valid i,j location.
484 any_valid_points = .false.
485 find_valid : DO j = jts,jte
486 DO i = its,ite
487 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
488 any_valid_points = .true.
489 i_valid = i
490 j_valid = j
491 EXIT find_valid
492 END DO
493 END DO find_valid
495 ! Replace traditional seaice field with optional seaice (AFWA source)
497 IF ( flag_icefrac .EQ. 1 ) THEN
498 DO j=jts,MIN(jde-1,jte)
499 DO i=its,MIN(ide-1,ite)
500 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
501 grid%xice(i,j) = grid%icefrac_gc(i,j)
502 END DO
503 END DO
504 END IF
506 ! Replace traditional seaice field with optional seaice percent (AFWA source)
508 IF ( flag_icepct .EQ. 1 ) THEN
509 DO j=jts,MIN(jde-1,jte)
510 DO i=its,MIN(ide-1,ite)
511 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
512 grid%xice(i,j) = grid%icepct(i,j)/100.
513 END DO
514 END DO
515 END IF
517 ! Fix the snow (water equivalent depth, kg/m^2) and the snowh (physical snow
518 ! depth, m) fields.
520 IF ( ( flag_snow .EQ. 0 ) .AND. ( flag_snowh .EQ. 0 ) ) THEN
521 DO j=jts,MIN(jde-1,jte)
522 DO i=its,MIN(ide-1,ite)
523 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
524 grid%snow(i,j) = 0.
525 grid%snowh(i,j) = 0.
526 END DO
527 END DO
529 ELSE IF ( ( flag_snow .EQ. 0 ) .AND. ( flag_snowh .EQ. 1 ) ) THEN
530 DO j=jts,MIN(jde-1,jte)
531 DO i=its,MIN(ide-1,ite)
532 ! ( m -> kg/m^2 ) & ( reduce to liquid, 5:1 ratio )
533 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
534 grid%snow(i,j) = grid%snowh(i,j) * 1000. / 5.
535 END DO
536 END DO
538 ELSE IF ( ( flag_snow .EQ. 1 ) .AND. ( flag_snowh .EQ. 0 ) ) THEN
539 DO j=jts,MIN(jde-1,jte)
540 DO i=its,MIN(ide-1,ite)
541 ! ( kg/m^2 -> m) & ( liquid to snow depth, 5:1 ratio )
542 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
543 grid%snowh(i,j) = grid%snow(i,j) / 1000. * 5.
544 END DO
545 END DO
547 END IF
549 ! For backward compatibility, we might need to assign the map factors from
550 ! what they were, to what they are.
552 IF ( ( config_flags%polar ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN
553 DO j=max(jds+1,jts),min(jde-1,jte)
554 DO i=its,min(ide-1,ite)
555 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
556 grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j)
557 END DO
558 END DO
559 IF(jts == jds) THEN
560 DO i=its,ite
561 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
562 grid%msfvx(i,jts) = 0.
563 grid%msfvx_inv(i,jts) = 0.
564 END DO
565 END IF
566 IF(jte == jde) THEN
567 DO i=its,ite
568 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
569 grid%msfvx(i,jte) = 0.
570 grid%msfvx_inv(i,jte) = 0.
571 END DO
572 END IF
573 ELSE IF ( ( .NOT. config_flags%polar ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN
574 IF ( grid%msfvx(its,jts) .EQ. 0 ) THEN
575 CALL wrf_error_fatal ( 'Maybe this is a global domain, but the polar flag was not set in the bdy_control namelist.' )
576 END IF
577 DO j=jts,min(jde,jte)
578 DO i=its,min(ide-1,ite)
579 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
580 grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j)
581 END DO
582 END DO
583 ELSE IF ( ( config_flags%polar ) .AND. ( flag_mf_xy .NE. 1 ) ) THEN
584 CALL wrf_error_fatal ( 'Older metgrid data cannot initialize a global domain' )
585 ENDIF
587 ! Check to see what available surface temperatures we have.
589 IF ( flag_tavgsfc .EQ. 1 ) THEN
590 we_have_tavgsfc = .TRUE.
591 ELSE
592 we_have_tavgsfc = .FALSE.
593 END IF
595 IF ( flag_tsk .EQ. 1 ) THEN
596 we_have_tsk = .TRUE.
597 ELSE
598 we_have_tsk = .FALSE.
599 END IF
601 IF ( config_flags%use_tavg_for_tsk ) THEN
602 IF ( we_have_tsk .OR. we_have_tavgsfc ) THEN
603 ! we are OK
604 ELSE
605 CALL wrf_error_fatal ( 'We either need TSK or TAVGSFC, verify these fields are coming from WPS' )
606 END IF
608 ! Since we require a skin temperature in the model, we can use the average 2-m temperature if provided.
610 IF ( we_have_tavgsfc ) THEN
611 DO j=jts,min(jde,jte)
612 DO i=its,min(ide-1,ite)
613 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
614 grid%tsk(i,j) = grid%tavgsfc(i,j)
615 END DO
616 END DO
617 END IF
618 END IF
620 ! Is there any vertical interpolation to do? The "old" data comes in on the correct
621 ! vertical locations already.
623 IF ( flag_metgrid .EQ. 1 ) THEN ! <----- START OF VERTICAL INTERPOLATION PART ---->
625 num_metgrid_levels = grid%num_metgrid_levels
627 IF ( config_flags%nest_interp_coord .EQ. 1 ) THEN
629 ! At the location of maximum pressure in the column, get the temperature and height. These
630 ! will be written out and could be used for vertical interpolation - to avoid extrapolation.
631 ! Hey, we can also do minimum values, too.
633 DO j=jts,jte
634 DO i=its,ite
635 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
636 grid%max_p(i,j) = grid%p_gc(i,1,j)
637 k_max_p = 1
638 IF ( grid%p_gc(i,2,j) .GT. grid%max_p(i,j) ) THEN
639 grid%max_p(i,j) = grid%p_gc(i,2,j)
640 k_max_p = 2
641 ELSE IF ( grid%p_gc(i,num_metgrid_levels,j) .GT. grid%max_p(i,j) ) THEN
642 grid%max_p(i,j) = grid%p_gc(i,num_metgrid_levels,j)
643 k_max_p = num_metgrid_levels
644 END IF
645 grid%t_max_p(i,j) = grid%t_gc(i,k_max_p,j)
646 grid%ght_max_p(i,j) = grid%ght_gc(i,k_max_p,j)
648 grid%min_p(i,j) = grid%p_gc(i,num_metgrid_levels,j)
649 k_min_p = num_metgrid_levels
650 IF ( grid%p_gc(i,2,j) .LT. grid%min_p(i,j) ) THEN
651 grid%min_p(i,j) = grid%p_gc(i,2,j)
652 k_min_p = 2
653 END IF
654 grid%t_min_p(i,j) = grid%t_gc(i,k_min_p,j)
655 grid%ght_min_p(i,j) = grid%ght_gc(i,k_min_p,j)
656 END DO
657 END DO
658 END IF
660 ! If this is data from the PINTERP program, it is emulating METGRID output.
661 ! One of the caveats of this data is the way that the vertical structure is
662 ! handled. We take the k=1 level and toss it (it is disposable), and we
663 ! swap in the surface data. This is done for all of the 3d fields about
664 ! which we show some interest: u, v, t, rh, ght, and p. For u, v, and rh,
665 ! we assume no interesting vertical structure, and just assign the 1000 mb
666 ! data. We directly use the 2-m temp for surface temp. We use the surface
667 ! pressure field and the topography elevation for the lowest level of
668 ! pressure and height, respectively.
670 IF ( flag_pinterp .EQ. 1 ) THEN
672 WRITE ( a_message , * ) 'Data from P_INTERP program, filling k=1 level with artificial surface fields.'
673 CALL wrf_message ( a_message )
674 DO j=jts,jte
675 DO i=its,ite
676 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
677 grid%u_gc(i,1,j) = grid%u_gc(i,2,j)
678 grid%v_gc(i,1,j) = grid%v_gc(i,2,j)
679 grid%rh_gc(i,1,j) = grid%rh_gc(i,2,j)
680 grid%t_gc(i,1,j) = grid%t2(i,j)
681 grid%ght_gc(i,1,j) = grid%ht(i,j)
682 grid%p_gc(i,1,j) = grid%psfc(i,j)
683 END DO
684 END DO
685 flag_psfc = 0
687 END IF
689 ! Variables that are named differently between SI and WPS.
691 DO j = jts, MIN(jte,jde-1)
692 DO i = its, MIN(ite,ide-1)
693 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
694 grid%tsk(i,j) = grid%tsk_gc(i,j)
695 grid%tmn(i,j) = grid%tmn_gc(i,j)
696 grid%xlat(i,j) = grid%xlat_gc(i,j)
697 grid%xlong(i,j) = grid%xlong_gc(i,j)
698 grid%ht(i,j) = grid%ht_gc(i,j)
699 END DO
700 END DO
702 ! A user could request that the most coarse grid has the
703 ! topography along the outer boundary smoothed. This smoothing
704 ! is similar to the coarse/nest interface. The outer rows and
705 ! cols come from the existing large scale topo, and then the
706 ! next several rows/cols are a linear ramp of the large scale
707 ! model and the hi-res topo from WPS. We only do this for the
708 ! coarse grid since we are going to make the interface consistent
709 ! in the model betwixt the CG and FG domains.
711 ! An important point is to inform the user if their request cannot
712 ! be satisfied. Do not skip over this quietly.
714 IF ( ( config_flags%smooth_cg_topo ) .AND. &
715 ( internal_time_loop .EQ. 1 ) .AND. &
716 ( grid%id .EQ. 1 ) .AND. &
717 ( flag_soilhgt .NE. 1) ) THEN
718 CALL wrf_message (' --- ERROR: NML option smooth_cg_topo=T')
719 CALL wrf_message (' But found no soil elevation / terrain / topography data in metgrid files')
720 CALL wrf_message (' The field SOILHGT is required when smoothing the CG topography on d01')
721 CALL wrf_error_fatal(' If using ERA5 data, possibly need to add more time invariant fields')
722 END IF
724 IF ( ( config_flags%smooth_cg_topo ) .AND. &
725 ( internal_time_loop .EQ. 1 ) .AND. &
726 ( grid%id .EQ. 1 ) .AND. &
727 ( flag_soilhgt .EQ. 1) ) THEN
728 CALL blend_terrain ( grid%toposoil , grid%ht , &
729 ids , ide , jds , jde , 1 , 1 , &
730 ims , ime , jms , jme , 1 , 1 , &
731 ips , ipe , jps , jpe , 1 , 1 )
732 DO j = jts, MIN(jte,jde-1)
733 DO i = its, MIN(ite,ide-1)
734 grid%ht_smooth(i,j) = grid%ht(i,j)
735 END DO
736 END DO
738 ELSE IF ( ( config_flags%smooth_cg_topo ) .AND. &
739 ( internal_time_loop .NE. 1 ) .AND. &
740 ( grid%id .EQ. 1 ) .AND. &
741 ( flag_soilhgt .EQ. 1) ) THEN
742 DO j = jts, MIN(jte,jde-1)
743 DO i = its, MIN(ite,ide-1)
744 grid%ht(i,j) = grid%ht_smooth(i,j)
745 END DO
746 END DO
748 END IF
750 ! Filter the input topography if this is a global domain.
752 IF ( ( config_flags%polar ) .AND. ( grid%fft_filter_lat .GT. 90 ) ) THEN
753 CALL wrf_error_fatal ( 'If the polar boundary condition is used, then fft_filter_lat must be set in namelist.input' )
754 END IF
756 IF ( ( config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( config_flags%polar ) ) THEN
757 #if 1
758 dclat = 90./REAL(jde-jds) !(0.5 * 180/ny)
759 DO j = jts, MIN(jte,jde-1)
760 DO k = kts, kte
761 DO i = its, MIN(ite,ide-1)
762 grid%t_2(i,k,j) = 1.
763 END DO
764 END DO
765 DO i = its, MIN(ite,ide-1)
766 grid%t_2(i,1,j) = grid%ht(i,j)
767 grid%sr(i,j) = grid%ht(i,j)
768 END DO
769 END DO
770 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
771 ! WARNING: this might present scaling issues on very large numbers of processors
772 ALLOCATE( clat_glob(ids:ide,jds:jde) )
774 CALL wrf_patch_to_global_real ( grid%clat, clat_glob, grid%domdesc, 'xy', 'xy', &
775 ids, ide, jds, jde, 1, 1, &
776 ims, ime, jms, jme, 1, 1, &
777 its, ite, jts, jte, 1, 1 )
779 CALL wrf_dm_bcast_real ( clat_glob , (ide-ids+1)*(jde-jds+1) )
781 grid%clat_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex)
783 find_j_index_of_fft_filter : DO j = jds , jde-1
784 IF ( ABS(clat_glob(ids,j)) .LE. config_flags%fft_filter_lat ) THEN
785 j_save = j
786 EXIT find_j_index_of_fft_filter
787 END IF
788 END DO find_j_index_of_fft_filter
790 CALL wrf_patch_to_global_real ( grid%msft, clat_glob, grid%domdesc, 'xy', 'xy', &
791 ids, ide, jds, jde, 1, 1, &
792 ims, ime, jms, jme, 1, 1, &
793 its, ite, jts, jte, 1, 1 )
795 CALL wrf_dm_bcast_real ( clat_glob , (ide-ids+1)*(jde-jds+1) )
797 grid%mf_fft = clat_glob(ids,j_save)
799 grid%mf_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex)
801 DEALLOCATE( clat_glob )
802 #else
803 find_j_index_of_fft_filter : DO j = jds , jde-1
804 IF ( ABS(grid%clat(ids,j)) .LE. config_flags%fft_filter_lat ) THEN
805 j_save = j
806 EXIT find_j_index_of_fft_filter
807 END IF
808 END DO find_j_index_of_fft_filter
809 grid%mf_fft = grid%msft(ids,j_save)
810 #endif
812 CALL pxft ( grid=grid &
813 ,lineno=__LINE__ &
814 ,flag_uv = 0 &
815 ,flag_rurv = 0 &
816 ,flag_wph = 0 &
817 ,flag_ww = 0 &
818 ,flag_t = 1 &
819 ,flag_mu = 0 &
820 ,flag_mut = 0 &
821 ,flag_moist = 0 &
822 ,flag_chem = 0 &
823 ,flag_tracer = 0 &
824 ,flag_scalar = 0 &
825 ,actual_distance_average = .TRUE. &
826 ,pos_def = .FALSE. &
827 ,swap_pole_with_next_j = .FALSE. &
828 ,moist=moist,chem=chem,tracer=tracer,scalar=scalar &
829 ,fft_filter_lat = config_flags%fft_filter_lat &
830 ,dclat = dclat &
831 ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde &
832 ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme &
833 ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe &
834 ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex &
835 ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
837 DO j = jts, MIN(jte,jde-1)
838 DO i = its, MIN(ite,ide-1)
839 grid%ht(i,j) = grid%t_2(i,1,j)
840 grid%sr(i,j) = grid%sr(i,j) - grid%ht(i,j)
841 END DO
842 END DO
844 #else
845 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
847 ! We stick the topo and map fac in an unused 3d array. The map scale
848 ! factor and computational latitude are passed along for the ride
849 ! (part of the transpose process - we only do 3d arrays) to determine
850 ! "how many" values are used to compute the mean. We want a number
851 ! that is consistent with the original grid resolution.
853 DO j = jts, MIN(jte,jde-1)
854 DO k = kts, kte
855 DO i = its, MIN(ite,ide-1)
856 grid%t_init(i,k,j) = 1.
857 END DO
858 END DO
859 DO i = its, MIN(ite,ide-1)
860 grid%t_init(i,1,j) = grid%ht(i,j)
861 grid%t_init(i,2,j) = grid%msftx(i,j)
862 grid%t_init(i,3,j) = grid%clat(i,j)
863 END DO
864 END DO
866 # include "XPOSE_POLAR_FILTER_TOPO_z2x.inc"
868 ! Retrieve the 2d arrays for topo, map factors, and the
869 ! computational latitude.
871 DO j = jpsx, MIN(jpex,jde-1)
872 DO i = ipsx, MIN(ipex,ide-1)
873 grid%ht_xxx(i,j) = grid%t_xxx(i,1,j)
874 grid%mf_xxx(i,j) = grid%t_xxx(i,2,j)
875 grid%clat_xxx(i,j) = grid%t_xxx(i,3,j)
876 END DO
877 END DO
879 ! Get a mean topo field that is consistent with the grid
880 ! distance on each computational latitude loop.
882 CALL filter_topo ( grid%ht_xxx , grid%clat_xxx , grid%mf_xxx , &
883 grid%fft_filter_lat , grid%mf_fft , &
884 .FALSE. , .FALSE. , &
885 ids, ide, jds, jde, 1 , 1 , &
886 imsx, imex, jmsx, jmex, 1, 1, &
887 ipsx, ipex, jpsx, jpex, 1, 1 )
889 ! Stick the filtered topo back into the dummy 3d array to
890 ! transpose it back to "all z on a patch".
892 DO j = jpsx, MIN(jpex,jde-1)
893 DO i = ipsx, MIN(ipex,ide-1)
894 grid%t_xxx(i,1,j) = grid%ht_xxx(i,j)
895 END DO
896 END DO
898 # include "XPOSE_POLAR_FILTER_TOPO_x2z.inc"
900 ! Get the un-transposed topo data.
902 DO j = jts, MIN(jte,jde-1)
903 DO i = its, MIN(ite,ide-1)
904 grid%ht(i,j) = grid%t_init(i,1,j)
905 END DO
906 END DO
907 #else
908 CALL filter_topo ( grid%ht , grid%clat , grid%msftx , &
909 grid%fft_filter_lat , grid%mf_fft , &
910 .FALSE. , .FALSE. , &
911 ids, ide, jds, jde, 1,1, &
912 ims, ime, jms, jme, 1,1, &
913 its, ite, jts, jte, 1,1 )
914 #endif
915 #endif
916 ELSE IF ( ( config_flags%map_proj .NE. PROJ_CASSINI ) .AND. ( config_flags%polar ) ) THEN
917 WRITE ( a_message,* ) 'A global domain (polar = true) requires the Cassini projection'
918 CALL wrf_error_fatal ( a_message )
919 END IF
921 ! If we have any input low-res surface pressure, we store it.
923 IF ( flag_psfc .EQ. 1 ) THEN
924 DO j = jts, MIN(jte,jde-1)
925 DO i = its, MIN(ite,ide-1)
926 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
927 grid%psfc_gc(i,j) = grid%psfc(i,j)
928 grid%p_gc(i,1,j) = grid%psfc(i,j)
929 END DO
930 END DO
931 END IF
933 ! If we have the low-resolution surface elevation, stick that in the
934 ! "input" locations of the 3d height. We still have the "hi-res" topo
935 ! stuck in the grid%ht array. The grid%landmask if test is required as some sources
936 ! have ZERO elevation over water (thank you very much).
938 IF ( flag_soilhgt .EQ. 1) THEN
939 DO j = jts, MIN(jte,jde-1)
940 DO i = its, MIN(ite,ide-1)
941 ! IF ( grid%landmask(i,j) .GT. 0.5 ) THEN
942 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
943 grid%ght_gc(i,1,j) = grid%toposoil(i,j)
944 grid%ht_gc(i,j)= grid%toposoil(i,j)
945 ! END IF
946 END DO
947 END DO
948 END IF
950 ! The number of vertical levels in the input data. There is no staggering for
951 ! different variables.
953 num_metgrid_levels = grid%num_metgrid_levels
955 ! For AFWA UM data, swap incoming extra (theta-based) pressure with the standardly
956 ! named (rho-based) pressure.
958 IF ( flag_ptheta .EQ. 1 ) THEN
959 DO j = jts, MIN(jte,jde-1)
960 DO k = 1 , num_metgrid_levels
961 DO i = its, MIN(ite,ide-1)
962 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
963 ptemp = grid%p_gc(i,k,j)
964 grid%p_gc(i,k,j) = grid%prho_gc(i,k,j)
965 grid%prho_gc(i,k,j) = ptemp
966 END DO
967 END DO
968 END DO
969 END IF
971 ! For UM data, the "surface" and the "first hybrid" level for the theta-level data fields are the same.
972 ! Average the surface (k=1) and the second hybrid level (k=num_metgrid_levels-1) to get the first hybrid
973 ! layer. We only do this for the theta-level data: pressure, temperature, specific humidity, and
974 ! geopotential height (i.e. we do not modify u, v, or the rho-based pressure).
976 IF ( ( flag_ptheta .EQ. 1 ) .OR. ( flag_prho .EQ. 1 ) ) THEN
977 DO j = jts, MIN(jte,jde-1)
978 DO i = its, MIN(ite,ide-1)
979 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
980 grid% p_gc(i,num_metgrid_levels,j) = ( grid% p_gc(i,1,j) + grid% p_gc(i,num_metgrid_levels-1,j) ) * 0.5
981 grid% t_gc(i,num_metgrid_levels,j) = ( grid% t_gc(i,1,j) + grid% t_gc(i,num_metgrid_levels-1,j) ) * 0.5
982 grid%ght_gc(i,num_metgrid_levels,j) = ( grid%ght_gc(i,1,j) + grid%ght_gc(i,num_metgrid_levels-1,j) ) * 0.5
983 END DO
984 END DO
986 IF ( grid%sh_gc(its,1,jts) .LT. 0 ) THEN
987 DO j = jts, MIN(jte,jde-1)
988 DO i = its, MIN(ite,ide-1)
989 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
990 grid% sh_gc(i,1,j) = 2. * grid% sh_gc(i,num_metgrid_levels,j) - grid% sh_gc(i,num_metgrid_levels-1,j)
991 END DO
992 END DO
993 END IF
994 IF ( grid%cl_gc(its,1,jts) .LT. 0 ) THEN
995 DO j = jts, MIN(jte,jde-1)
996 DO i = its, MIN(ite,ide-1)
997 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
998 grid% cl_gc(i,1,j) = 2. * grid% cl_gc(i,num_metgrid_levels,j) - grid% cl_gc(i,num_metgrid_levels-1,j)
999 END DO
1000 END DO
1001 END IF
1002 IF ( grid%cf_gc(its,1,jts) .LT. 0 ) THEN
1003 DO j = jts, MIN(jte,jde-1)
1004 DO i = its, MIN(ite,ide-1)
1005 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1006 grid% cf_gc(i,1,j) = 2. * grid% cf_gc(i,num_metgrid_levels,j) - grid% cf_gc(i,num_metgrid_levels-1,j)
1007 END DO
1008 END DO
1009 END IF
1010 END IF
1012 ! For UM data, the soil moisture comes in as kg / m^2. Divide by 1000 and layer thickness to get m^3 / m^3.
1014 IF ( flag_prho .EQ. 1 ) THEN
1016 levels(1) = 0.
1017 levels(2) = ( 2. * sm_levels_input(1) )
1018 DO k = 2 , num_sm_levels_input
1019 levels(k+1) = ( 2. * sm_levels_input(k) ) - levels(k)
1020 END DO
1021 DO k = 1 , num_sm_levels_input
1022 thickness(k) = ( levels(k+1) - levels(k) ) / 100.
1023 END DO
1025 DO j = jts, MIN(jte,jde-1)
1026 DO k = 1 , num_sm_levels_input
1027 DO i = its, MIN(ite,ide-1)
1028 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1029 sm_input(i,k+1,j) = MAX ( 0. , sm_input(i,k+1,j) / 1000. / thickness(k) )
1030 END DO
1031 END DO
1032 END DO
1033 END IF
1035 IF ( any_valid_points ) THEN
1036 ! Check for and semi-fix missing surface fields.
1038 IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
1039 k = 2
1040 ELSE
1041 k = num_metgrid_levels
1042 END IF
1044 IF ( grid%t_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
1045 DO j = jts, MIN(jte,jde-1)
1046 DO i = its, MIN(ite,ide-1)
1047 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1048 grid%t_gc(i,1,j) = grid%t_gc(i,k,j)
1049 END DO
1050 END DO
1051 config_flags%use_surface = .FALSE.
1052 grid%use_surface = .FALSE.
1053 WRITE ( a_message , * ) 'Missing surface temp, replaced with closest level, use_surface set to false.'
1054 CALL wrf_message ( a_message )
1055 END IF
1057 IF ( grid%rh_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
1058 DO j = jts, MIN(jte,jde-1)
1059 DO i = its, MIN(ite,ide-1)
1060 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1061 grid%rh_gc(i,1,j) = grid%rh_gc(i,k,j)
1062 END DO
1063 END DO
1064 config_flags%use_surface = .FALSE.
1065 grid%use_surface = .FALSE.
1066 WRITE ( a_message , * ) 'Missing surface RH, replaced with closest level, use_surface set to false.'
1067 CALL wrf_message ( a_message )
1068 END IF
1070 IF ( grid%u_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
1071 DO j = jts, MIN(jte,jde-1)
1072 DO i = its, ite
1073 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1074 grid%u_gc(i,1,j) = grid%u_gc(i,k,j)
1075 END DO
1076 END DO
1077 config_flags%use_surface = .FALSE.
1078 grid%use_surface = .FALSE.
1079 WRITE ( a_message , * ) 'Missing surface u wind, replaced with closest level, use_surface set to false.'
1080 CALL wrf_message ( a_message )
1081 END IF
1083 IF ( grid%v_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN
1084 DO j = jts, jte
1085 DO i = its, MIN(ite,ide-1)
1086 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1087 grid%v_gc(i,1,j) = grid%v_gc(i,k,j)
1088 END DO
1089 END DO
1090 config_flags%use_surface = .FALSE.
1091 grid%use_surface = .FALSE.
1092 WRITE ( a_message , * ) 'Missing surface v wind, replaced with closest level, use_surface set to false.'
1093 CALL wrf_message ( a_message )
1094 END IF
1096 ! Compute the mixing ratio from the input relative humidity.
1098 IF ( ( flag_qv .NE. 1 ) .AND. ( flag_sh .NE. 1 ) ) THEN
1099 IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
1100 k = 2
1101 ELSE
1102 k = num_metgrid_levels
1103 END IF
1105 IF ( config_flags%rh2qv_method .eq. 1 ) THEN
1106 CALL rh_to_mxrat1(grid%rh_gc, grid%t_gc, grid%p_gc, grid%qv_gc , &
1107 config_flags%rh2qv_wrt_liquid , &
1108 config_flags%qv_max_p_safe , &
1109 config_flags%qv_max_flag , config_flags%qv_max_value , &
1110 config_flags%qv_min_p_safe , &
1111 config_flags%qv_min_flag , config_flags%qv_min_value , &
1112 ids , ide , jds , jde , 1 , num_metgrid_levels , &
1113 ims , ime , jms , jme , 1 , num_metgrid_levels , &
1114 its , ite , jts , jte , 1 , num_metgrid_levels )
1115 ELSE IF ( config_flags%rh2qv_method .eq. 2 ) THEN
1116 CALL rh_to_mxrat2(grid%rh_gc, grid%t_gc, grid%p_gc, grid%qv_gc , &
1117 config_flags%rh2qv_wrt_liquid , &
1118 config_flags%qv_max_p_safe , &
1119 config_flags%qv_max_flag , config_flags%qv_max_value , &
1120 config_flags%qv_min_p_safe , &
1121 config_flags%qv_min_flag , config_flags%qv_min_value , &
1122 ids , ide , jds , jde , 1 , num_metgrid_levels , &
1123 ims , ime , jms , jme , 1 , num_metgrid_levels , &
1124 its , ite , jts , jte , 1 , num_metgrid_levels )
1125 END IF
1128 ELSE IF ( flag_sh .EQ. 1 ) THEN
1129 IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
1130 k = 2
1131 ELSE
1132 k = num_metgrid_levels
1133 END IF
1134 IF ( grid%sh_gc(i_valid,kts,j_valid) .LT. 1.e-6 ) THEN
1135 DO j = jts, MIN(jte,jde-1)
1136 DO i = its, MIN(ite,ide-1)
1137 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1138 grid%sh_gc(i,1,j) = grid%sh_gc(i,k,j)
1139 END DO
1140 END DO
1141 END IF
1143 DO j = jts, MIN(jte,jde-1)
1144 DO k = 1 , num_metgrid_levels
1145 DO i = its, MIN(ite,ide-1)
1146 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1147 grid%qv_gc(i,k,j) = grid%sh_gc(i,k,j) /( 1. - grid%sh_gc(i,k,j) )
1148 sat_vap_pres_mb = 0.6112*10.*EXP(17.67*(grid%t_gc(i,k,j)-273.15)/(grid%t_gc(i,k,j)-29.65))
1149 vap_pres_mb = grid%qv_gc(i,k,j) * grid%p_gc(i,k,j)/100. / (grid%qv_gc(i,k,j) + 0.622 )
1150 IF ( sat_vap_pres_mb .GT. 0 ) THEN
1151 grid%rh_gc(i,k,j) = ( vap_pres_mb / sat_vap_pres_mb ) * 100.
1152 ELSE
1153 grid%rh_gc(i,k,j) = 0.
1154 END IF
1155 END DO
1156 END DO
1157 END DO
1159 ELSE IF ( flag_qv .EQ. 1 ) THEN
1160 IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN
1161 k = 2
1162 ELSE
1163 k = num_metgrid_levels
1164 END IF
1166 DO j = jts, MIN(jte,jde-1)
1167 DO k = 1 , num_metgrid_levels
1168 DO i = its, MIN(ite,ide-1)
1169 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1170 sat_vap_pres_mb = 0.6112*10.*EXP(17.67*(grid%t_gc(i,k,j)-273.15)/(grid%t_gc(i,k,j)-29.65))
1171 vap_pres_mb = grid%qv_gc(i,k,j) * grid%p_gc(i,k,j)/100. / (grid%qv_gc(i,k,j) + 0.622 )
1172 IF ( sat_vap_pres_mb .GT. 0 ) THEN
1173 grid%rh_gc(i,k,j) = ( vap_pres_mb / sat_vap_pres_mb ) * 100.
1174 ELSE
1175 grid%rh_gc(i,k,j) = 0.
1176 END IF
1177 END DO
1178 END DO
1179 END DO
1181 END IF
1183 ! Some data sets do not provide a 3d geopotential height field.
1185 IF ( grid%ght_gc(i_valid,grid%num_metgrid_levels/2,j_valid) .LT. 1 ) THEN
1186 DO j = jts, MIN(jte,jde-1)
1187 DO k = kts+1 , grid%num_metgrid_levels
1188 DO i = its, MIN(ite,ide-1)
1189 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1190 grid%ght_gc(i,k,j) = grid%ght_gc(i,k-1,j) - &
1191 R_d / g * 0.5 * ( grid%t_gc(i,k ,j) * ( 1 + 0.608 * grid%qv_gc(i,k ,j) ) + &
1192 grid%t_gc(i,k-1,j) * ( 1 + 0.608 * grid%qv_gc(i,k-1,j) ) ) * &
1193 LOG ( grid%p_gc(i,k,j) / grid%p_gc(i,k-1,j) )
1194 END DO
1195 END DO
1196 END DO
1197 END IF
1199 ! If the pressure levels in the middle of the atmosphere are upside down, then
1200 ! this is hybrid data. Computing the new surface pressure should use sfcprs2.
1202 IF ( grid%p_gc(i_valid,num_metgrid_levels/2,j_valid) .LT. grid%p_gc(i_valid,num_metgrid_levels/2+1,j_valid) ) THEN
1203 config_flags%sfcp_to_sfcp = .TRUE.
1204 END IF
1205 END IF
1207 ! Assign surface fields with original input values. If this is hybrid data,
1208 ! the values are not exactly representative. However - this is only for
1209 ! plotting purposes and such at the 0h of the forecast, so we are not all that
1210 ! worried.
1212 DO j = jts, min(jde-1,jte)
1213 DO i = its, min(ide,ite)
1214 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1215 grid%u10(i,j)=grid%u_gc(i,1,j)
1216 END DO
1217 END DO
1219 DO j = jts, min(jde,jte)
1220 DO i = its, min(ide-1,ite)
1221 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1222 grid%v10(i,j)=grid%v_gc(i,1,j)
1223 END DO
1224 END DO
1226 DO j = jts, min(jde-1,jte)
1227 DO i = its, min(ide-1,ite)
1228 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1229 grid%t2(i,j)=grid%t_gc(i,1,j)
1230 END DO
1231 END DO
1233 IF ( flag_qv .EQ. 1 ) THEN
1234 DO j = jts, min(jde-1,jte)
1235 DO i = its, min(ide-1,ite)
1236 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1237 grid%q2(i,j)=grid%qv_gc(i,1,j)
1238 END DO
1239 END DO
1240 END IF
1242 ! The requested ptop for real data cases.
1244 p_top_requested = grid%p_top_requested
1246 ! Compute the top pressure, grid%p_top. For isobaric data, this is just the
1247 ! top level. For the generalized vertical coordinate data, we find the
1248 ! max pressure on the top level. We have to be careful of two things:
1249 ! 1) the value has to be communicated, 2) the value can not increase
1250 ! at subsequent times from the initial value.
1252 IF ( internal_time_loop .EQ. 1 ) THEN
1253 CALL find_p_top ( grid%p_gc , grid%p_top , &
1254 ids , ide , jds , jde , 1 , num_metgrid_levels , &
1255 ims , ime , jms , jme , 1 , num_metgrid_levels , &
1256 its , ite , jts , jte , 1 , num_metgrid_levels )
1258 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
1259 grid%p_top = wrf_dm_max_real ( grid%p_top )
1260 #endif
1262 ! Compare the requested grid%p_top with the value available from the input data.
1264 IF ( p_top_requested .LT. grid%p_top ) THEN
1265 print *,'p_top_requested = ',p_top_requested
1266 print *,'allowable grid%p_top in data = ',grid%p_top
1267 CALL wrf_error_fatal ( 'p_top_requested < grid%p_top possible from data' )
1268 END IF
1270 ! The grid%p_top valus is the max of what is available from the data and the
1271 ! requested value. We have already compared <, so grid%p_top is directly set to
1272 ! the value in the namelist.
1274 grid%p_top = p_top_requested
1276 ! For subsequent times, we have to remember what the grid%p_top for the first
1277 ! time was. Why? If we have a generalized vert coordinate, the grid%p_top value
1278 ! could fluctuate.
1280 p_top_save = grid%p_top
1282 ELSE
1283 CALL find_p_top ( grid%p_gc , grid%p_top , &
1284 ids , ide , jds , jde , 1 , num_metgrid_levels , &
1285 ims , ime , jms , jme , 1 , num_metgrid_levels , &
1286 its , ite , jts , jte , 1 , num_metgrid_levels )
1288 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
1289 grid%p_top = wrf_dm_max_real ( grid%p_top )
1290 #endif
1291 IF ( grid%p_top .GT. p_top_save ) THEN
1292 print *,'grid%p_top from last time period = ',p_top_save
1293 print *,'grid%p_top from this time period = ',grid%p_top
1294 CALL wrf_error_fatal ( 'grid%p_top > previous value' )
1295 END IF
1296 grid%p_top = p_top_save
1297 ENDIF
1299 ! Get the monthly values interpolated to the current date for the traditional monthly
1300 ! fields of green-ness fraction and background albedo.
1302 CALL monthly_interp_to_date ( grid%greenfrac , current_date , grid%vegfra , &
1303 ids , ide , jds , jde , kds , kde , &
1304 ims , ime , jms , jme , kms , kme , &
1305 its , ite , jts , jte , kts , kte )
1307 CALL monthly_interp_to_date ( grid%albedo12m , current_date , grid%albbck , &
1308 ids , ide , jds , jde , kds , kde , &
1309 ims , ime , jms , jme , kms , kme , &
1310 its , ite , jts , jte , kts , kte )
1312 CALL monthly_interp_to_date ( grid%lai12m , current_date , grid%lai , &
1313 ids , ide , jds , jde , kds , kde , &
1314 ims , ime , jms , jme , kms , kme , &
1315 its , ite , jts , jte , kts , kte )
1317 #if ( WRF_CHEM == 1 )
1318 ! Chose the appropriate LAI veg mask for this date (used in the AFWA dust model)
1320 CALL eightday_selector ( grid%lai_veg_8day , current_date , grid%lai_vegmask , &
1321 ids , ide , jds , jde , kds , kde , &
1322 ims , ime , jms , jme , kms , kme , &
1323 its , ite , jts , jte , kts , kte )
1324 #endif
1326 ! Get the min/max of each i,j for the monthly green-ness fraction.
1328 CALL monthly_min_max ( grid%greenfrac , grid%shdmin , grid%shdmax , &
1329 ids , ide , jds , jde , kds , kde , &
1330 ims , ime , jms , jme , kms , kme , &
1331 its , ite , jts , jte , kts , kte )
1333 ! The model expects the green-ness and vegetation fraction values to be in percent, not fraction.
1335 DO j = jts, MIN(jte,jde-1)
1336 DO i = its, MIN(ite,ide-1)
1337 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1338 grid%vegfra(i,j) = grid%vegfra(i,j) * 100.
1339 grid%shdmax(i,j) = grid%shdmax(i,j) * 100.
1340 grid%shdmin(i,j) = grid%shdmin(i,j) * 100.
1341 END DO
1342 END DO
1344 ! The model expects the albedo fields as a fraction, not a percent. Set the
1345 ! water values to 8%.
1347 DO j = jts, MIN(jte,jde-1)
1348 DO i = its, MIN(ite,ide-1)
1349 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1350 grid%albbck(i,j) = grid%albbck(i,j) / 100.
1351 grid%snoalb(i,j) = grid%snoalb(i,j) / 100.
1352 IF ( grid%landmask(i,j) .LT. 0.5 ) THEN
1353 grid%albbck(i,j) = 0.08
1354 grid%snoalb(i,j) = 0.08
1355 END IF
1356 END DO
1357 END DO
1359 ! Two ways to get the surface pressure. 1) If we have the low-res input surface
1360 ! pressure and the low-res topography, then we can do a simple hydrostatic
1361 ! relation. 2) Otherwise we compute the surface pressure from the sea-level
1362 ! pressure.
1363 ! Note that on output, grid%psfc is now hi-res. The low-res surface pressure and
1364 ! elevation are grid%psfc_gc and grid%ht_gc (same as grid%ght_gc(k=1)).
1366 IF ( ( flag_psfc .EQ. 1 ) .AND. &
1367 ( flag_soilhgt .EQ. 1 ) .AND. &
1368 ( flag_slp .EQ. 1 ) .AND. &
1369 ( .NOT. config_flags%sfcp_to_sfcp ) ) THEN
1370 WRITE(a_message,FMT='(A)') 'Using sfcprs3 to compute psfc'
1371 CALL wrf_message ( a_message )
1372 CALL sfcprs3(grid%ght_gc, grid%p_gc, grid%ht, &
1373 grid%pslv_gc, grid%psfc, &
1374 ids , ide , jds , jde , 1 , num_metgrid_levels , &
1375 ims , ime , jms , jme , 1 , num_metgrid_levels , &
1376 its , ite , jts , jte , 1 , num_metgrid_levels )
1377 ELSE IF ( ( flag_psfc .EQ. 1 ) .AND. &
1378 ( flag_soilhgt .EQ. 1 ) .AND. &
1379 ( config_flags%sfcp_to_sfcp ) ) THEN
1380 WRITE(a_message,FMT='(A)') 'Using sfcprs2 to compute psfc'
1381 CALL wrf_message ( a_message )
1382 CALL sfcprs2(grid%t_gc, grid%qv_gc, grid%ght_gc, grid%psfc_gc, grid%ht, &
1383 grid%tavgsfc, grid%p_gc, grid%psfc, we_have_tavgsfc, &
1384 ids , ide , jds , jde , 1 , num_metgrid_levels , &
1385 ims , ime , jms , jme , 1 , num_metgrid_levels , &
1386 its , ite , jts , jte , 1 , num_metgrid_levels )
1387 ELSE IF ( flag_slp .EQ. 1 ) THEN
1388 WRITE(a_message,FMT='(A)') 'Using sfcprs to compute psfc'
1389 CALL wrf_message ( a_message )
1390 CALL sfcprs (grid%t_gc, grid%qv_gc, grid%ght_gc, grid%pslv_gc, grid%ht, &
1391 grid%tavgsfc, grid%p_gc, grid%psfc, we_have_tavgsfc, &
1392 ids , ide , jds , jde , 1 , num_metgrid_levels , &
1393 ims , ime , jms , jme , 1 , num_metgrid_levels , &
1394 its , ite , jts , jte , 1 , num_metgrid_levels )
1395 ELSE
1396 WRITE(a_message,FMT='(3(A,I2),A,L1)') 'ERROR in psfc: flag_psfc = ',flag_psfc, &
1397 ', flag_soilhgt = ',flag_soilhgt , &
1398 ', flag_slp = ',flag_slp , &
1399 ', sfcp_to_sfcp = ',config_flags%sfcp_to_sfcp
1400 CALL wrf_message ( a_message )
1401 CALL wrf_error_fatal ( 'not enough info for a p sfc computation' )
1402 END IF
1404 ! If we have no input surface pressure, we'd better stick something in there.
1406 IF ( flag_psfc .NE. 1 ) THEN
1407 DO j = jts, MIN(jte,jde-1)
1408 DO i = its, MIN(ite,ide-1)
1409 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1410 grid%psfc_gc(i,j) = grid%psfc(i,j)
1411 grid%p_gc(i,1,j) = grid%psfc(i,j)
1412 END DO
1413 END DO
1414 END IF
1416 ! Integrate the mixing ratio to get the vapor pressure.
1418 CALL integ_moist ( grid%qv_gc , grid%p_gc , grid%pd_gc , grid%t_gc , grid%ght_gc , grid%intq_gc , &
1419 ids , ide , jds , jde , 1 , num_metgrid_levels , &
1420 ims , ime , jms , jme , 1 , num_metgrid_levels , &
1421 its , ite , jts , jte , 1 , num_metgrid_levels )
1423 ! If this is UM data, the same moisture removed from the "theta" level pressure data can
1424 ! be removed from the "rho" level pressures. This is an approximation. We'll revisit to
1425 ! see if this is a bad idea.
1427 IF ( flag_ptheta .EQ. 1 ) THEN
1428 DO j = jts, MIN(jte,jde-1)
1429 DO k = num_metgrid_levels-1 , 1 , -1
1430 DO i = its, MIN(ite,ide-1)
1431 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1432 ptemp = ((grid%p_gc(i,k,j) - grid%pd_gc(i,k,j)) + (grid%p_gc(i,k+1,j) - grid%pd_gc(i,k+1,j)))/2
1433 grid%pdrho_gc(i,k,j) = grid%prho_gc(i,k,j) - ptemp
1434 END DO
1435 END DO
1436 END DO
1437 END IF
1440 ! Compute the difference between the dry, total surface pressure (input) and the
1441 ! dry top pressure (constant).
1443 CALL p_dts ( grid%mu0 , grid%intq_gc , grid%psfc , grid%p_top , &
1444 ids , ide , jds , jde , 1 , num_metgrid_levels , &
1445 ims , ime , jms , jme , 1 , num_metgrid_levels , &
1446 its , ite , jts , jte , 1 , num_metgrid_levels )
1448 ! Compute the dry, hydrostatic surface pressure.
1450 CALL p_dhs ( grid%pdhs , grid%ht , p00 , t00 , a , &
1451 ids , ide , jds , jde , kds , kde , &
1452 ims , ime , jms , jme , kms , kme , &
1453 its , ite , jts , jte , kts , kte )
1455 ! Compute the eta levels if not defined already.
1457 IF ( grid%znw(1) .NE. 1.0 ) THEN
1458 !DJW Check if any of the domains are going to use vertical
1459 !nesting with vert_refine_method=2. If so, set vnest as true.
1460 vnest = .FALSE.
1461 DO id=1,model_config_rec%max_dom
1462 IF (model_config_rec%vert_refine_method(id) .EQ. 2) THEN
1463 vnest = .TRUE.
1464 ENDIF
1465 ENDDO
1466 !DJW If there are eta_levels defined in the namelist and at
1467 !least one domain is using vertical nesting, then we need to read in
1468 !the eta_levels.
1469 IF ((model_config_rec%eta_levels(1) .NE. -1.0) .AND. (vnest)) THEN
1470 !DJW Added code for specifying multiple domains' eta_levels.
1471 !First check to make sure that we've not specified more
1472 !eta_levels than the dimensionality of eta_levels can handle! This
1473 !issue will most likely cause a break sometime before this
1474 !check, however it doesn't hurt to include it. To increase max_eta,
1475 !go to frame/module_driver_constants.F.
1476 CALL wrf_debug (0, "module_initialize_real: using vert_refine_method=2, reading in eta_levels from namelist.input")
1477 ks = 0
1478 DO id=1,grid%id
1479 ks = ks+model_config_rec%e_vert(id)
1480 ENDDO
1481 IF (ks .GT. max_eta) THEN
1482 CALL wrf_error_fatal("too many vertical levels, increase max_eta in frame/module_driver_constants.F")
1483 ENDIF
1484 !Now set the eta_levels to what we specified in the namelist. We've
1485 !packed all the domains' eta_levels into a 'vector' and now we need
1486 !to pull only the section of the vector associated with our domain
1487 !of interest, which is between indicies ks and ke.
1488 IF (grid%id .EQ. 1) THEN
1489 ks = 1
1490 ke = model_config_rec%e_vert(1)
1491 ELSE
1492 id = 1
1493 ks = 1
1494 ke = 0
1495 DO WHILE (grid%id .GT. id)
1496 id = id+1
1497 ks = ks+model_config_rec%e_vert(id-1)
1498 ke = ks+model_config_rec%e_vert(id)-1
1499 ENDDO
1500 ENDIF
1501 eta_levels(1:kde) = model_config_rec%eta_levels(ks:ke)
1502 !Check the value of the first and last eta level for our domain,
1503 !then check that the vector of eta levels is only decreasing
1504 IF (eta_levels(1) .NE. 1.0) THEN
1505 CALL wrf_error_fatal("--- ERROR: the first specified eta_level is not 1.0")
1506 ENDIF
1507 IF (eta_levels(kde) .NE. 0.0) THEN
1508 CALL wrf_error_fatal("--- ERROR: the last specified eta_level is not 0.0")
1509 ENDIF
1510 DO k=2,kde
1511 IF (eta_levels(k) .GT. eta_levels(k-1)) THEN
1512 CALL wrf_error_fatal("--- ERROR: specified eta_levels are not uniformly decreasing from 1.0 to 0.0")
1513 ENDIF
1514 ENDDO
1515 !DJW End of added code for specifying eta_levels
1516 ELSE !We're not using vertical nesting with eta_levels defined for every domain
1517 !DJW Check if we're doing vertical nesting with integer refinement.
1518 vnest = .FALSE.
1519 DO id=1,model_config_rec%max_dom
1520 IF (model_config_rec%vert_refine_method(id) .EQ. 1) THEN
1521 vnest = .TRUE.
1522 ENDIF
1523 ENDDO
1524 !DJW If we're doing vertical nesting using integer refinement and
1525 !we've got eta_levels specified in the namelist then make sure they are
1526 !for the parent domain and nothing else.
1527 IF ((vnest) .AND. (model_config_rec%eta_levels(kde+1) .NE. -1.0)) THEN
1528 write(wrf_err_message,'(A)') "--- ERROR: too many eta_levels defined in namelist.input."
1529 CALL wrf_error_fatal( wrf_err_message )
1530 !DJW Check the value of the first and last eta level for our
1531 !domain, then check that the vector of eta levels is only decreasing
1532 ELSEIF ((vnest) .AND. (model_config_rec%eta_levels(1) .NE. -1.0)) THEN
1533 CALL wrf_debug(0, "module_initialize_real: using vert_refine_method=1, reading in eta_levels for d01 from namelist.input")
1534 eta_levels(1:kde) = model_config_rec%eta_levels(1:kde)
1535 IF (eta_levels(1) .NE. 1.0) THEN
1536 CALL wrf_error_fatal("--- ERROR: the first specified eta_level is not 1.0")
1537 ENDIF
1538 IF (eta_levels(kde) .NE. 0.0) THEN
1539 CALL wrf_error_fatal("--- ERROR: the last specified eta_level is not 0.0")
1540 ENDIF
1541 DO k=2,kde
1542 IF (eta_levels(k) .GT. eta_levels(k-1)) THEN
1543 CALL wrf_error_fatal("--- ERROR: specified eta_levels are not uniformly decreasing from 1.0 to 0.0")
1544 ENDIF
1545 ENDDO
1546 ELSE
1547 !DJW original code to set eta_levels
1548 eta_levels(1:kde) = model_config_rec%eta_levels(1:kde)
1549 ENDIF
1550 ENDIF
1552 max_dz = model_config_rec%max_dz
1553 dzbot = model_config_rec%dzbot
1554 dzstretch_s = model_config_rec%dzstretch_s
1555 dzstretch_u = model_config_rec%dzstretch_u
1556 auto_levels_opt = model_config_rec%auto_levels_opt
1558 CALL compute_eta ( grid%znw , auto_levels_opt, &
1559 eta_levels , max_eta , max_dz , dzbot , dzstretch_s , dzstretch_u , &
1560 grid%p_top , g , p00 , cvpm , a , r_d , cp , &
1561 t00 , p1000mb , t0 , tiso , p_strat , a_strat , &
1562 ids , ide , jds , jde , kds , kde , &
1563 ims , ime , jms , jme , kms , kme , &
1564 its , ite , jts , jte , kts , kte )
1565 END IF
1567 ! For vertical coordinate, compute 1d arrays.
1569 CALL compute_vcoord_1d_coeffs ( grid%ht, grid%etac, grid%znw, &
1570 config_flags%hybrid_opt, &
1571 r_d, g, p1000mb, &
1572 grid%p_top, grid%p00, grid%t00, grid%tlp, &
1573 ids, ide, jds, jde, kds, kde, &
1574 ims, ime, jms, jme, kms, kme, &
1575 its, ite, jts, jte, kts, kte, &
1576 grid%znu, &
1577 grid%c1f, grid%c2f, grid%c3f, grid%c4f, &
1578 grid%c1h, grid%c2h, grid%c3h, grid%c4h )
1580 IF ( config_flags%interp_theta ) THEN
1582 ! The input field is temperature, we want potential temp.
1584 CALL t_to_theta ( grid%t_gc , grid%p_gc , p00 , &
1585 ids , ide , jds , jde , 1 , num_metgrid_levels , &
1586 ims , ime , jms , jme , 1 , num_metgrid_levels , &
1587 its , ite , jts , jte , 1 , num_metgrid_levels )
1588 END IF
1590 IF ( flag_slp .EQ. 1 ) THEN
1592 ! On the eta surfaces, compute the dry pressure = mu eta, stored in
1593 ! grid%pb, since it is a pressure, and we don't need another kms:kme 3d
1594 ! array floating around. The grid%pb array is re-computed as the base pressure
1595 ! later after the vertical interpolations are complete.
1597 CALL p_dry ( grid%mu0 , grid%znw , grid%p_top , grid%pb , want_full_levels , &
1598 grid%c3f , grid%c3h , grid%c4f , grid%c4h , &
1599 ids , ide , jds , jde , kds , kde , &
1600 ims , ime , jms , jme , kms , kme , &
1601 its , ite , jts , jte , kts , kte )
1603 ! All of the vertical interpolations are done in dry-pressure space. The
1604 ! input data has had the moisture removed (grid%pd_gc). The target levels (grid%pb)
1605 ! had the vapor pressure removed from the surface pressure, then they were
1606 ! scaled by the eta levels.
1608 interp_type = 2
1609 lagrange_order = grid%lagrange_order
1610 linear_interp = grid%linear_interp
1611 lowest_lev_from_sfc = .FALSE.
1612 use_levels_below_ground = .TRUE.
1613 use_surface = .TRUE.
1614 zap_close_levels = grid%zap_close_levels
1615 force_sfc_in_vinterp = 0
1616 t_extrap_type = grid%t_extrap_type
1617 extrap_type = 1
1619 ! For the height field, the lowest level pressure is the slp (approximately "dry"). The
1620 ! lowest level of the input height field (to be associated with slp) then is an array
1621 ! of zeros.
1623 DO j = jts, MIN(jte,jde-1)
1624 DO i = its, MIN(ite,ide-1)
1625 grid%psfc_gc(i,j) = grid%pd_gc(i,1,j)
1626 grid%pd_gc(i,1,j) = grid%pslv_gc(i,j) - ( grid%p_gc(i,1,j) - grid%pd_gc(i,1,j) )
1627 grid%ht_gc(i,j) = grid%ght_gc(i,1,j)
1628 grid%ght_gc(i,1,j) = 0.
1629 END DO
1630 END DO
1632 #ifdef DM_PARALLEL
1633 ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte
1635 ! Stencil for pressure is required for the pressure difference for the max_wind
1636 ! and trop level data.
1638 # include "HALO_EM_VINTERP_UV_1.inc"
1639 #endif
1641 CALL vert_interp ( grid%ght_gc , grid%pd_gc , grid%ph0 , grid%pb , &
1642 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1643 grid%pmaxwnn , grid%ptropnn , &
1644 flag_hgtmaxw , flag_hgttrop , &
1645 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1646 config_flags%maxw_above_this_level , &
1647 num_metgrid_levels , 'Z' , &
1648 interp_type , lagrange_order , extrap_type , &
1649 lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
1650 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1651 ids , ide , jds , jde , kds , kde , &
1652 ims , ime , jms , jme , kms , kme , &
1653 its , ite , jts , jte , kts , kte )
1655 ! Put things back to normal.
1657 DO j = jts, MIN(jte,jde-1)
1658 DO i = its, MIN(ite,ide-1)
1659 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1660 grid%pd_gc(i,1,j) = grid%psfc_gc(i,j)
1661 grid%ght_gc(i,1,j) = grid%ht_gc(i,j)
1662 END DO
1663 END DO
1665 END IF
1667 ! Now the rest of the variables on half-levels to inteprolate.
1669 CALL p_dry ( grid%mu0 , grid%znw , grid%p_top , grid%pb , want_half_levels , &
1670 grid%c3f , grid%c3h , grid%c4f , grid%c4h , &
1671 ids , ide , jds , jde , kds , kde , &
1672 ims , ime , jms , jme , kms , kme , &
1673 its , ite , jts , jte , kts , kte )
1675 interp_type = grid%interp_type
1676 lagrange_order = grid%lagrange_order
1677 lowest_lev_from_sfc = grid%lowest_lev_from_sfc
1678 use_levels_below_ground = grid%use_levels_below_ground
1679 use_surface = grid%use_surface
1680 zap_close_levels = grid%zap_close_levels
1681 force_sfc_in_vinterp = grid%force_sfc_in_vinterp
1682 t_extrap_type = grid%t_extrap_type
1683 extrap_type = grid%extrap_type
1685 #ifdef DM_PARALLEL
1686 ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte
1688 ! Stencil for pressure is required for the pressure difference for the max_wind
1689 ! and trop level data.
1691 # include "HALO_EM_VINTERP_UV_1.inc"
1692 #endif
1694 ! Interpolate RH, diagnose Qv later when have temp and pressure. Temporarily
1695 ! store this in the u_1 space, for later diagnosis into Qv and stored into moist.
1697 CALL vert_interp ( grid%rh_gc , grid%pd_gc , grid%u_1 , grid%pb , &
1698 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1699 grid%pmaxwnn , grid%ptropnn , &
1700 0 , 0 , &
1701 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1702 config_flags%maxw_above_this_level , &
1703 num_metgrid_levels , 'Q' , &
1704 interp_type , lagrange_order , extrap_type , &
1705 lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
1706 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1707 ids , ide , jds , jde , kds , kde , &
1708 ims , ime , jms , jme , kms , kme , &
1709 its , ite , jts , jte , kts , kte )
1711 ! If this is theta being interpolated, AND we have extra levels for temperature,
1712 ! convert those extra levels (trop and max wind) to potential temp.
1714 IF ( ( config_flags%interp_theta ) .AND. ( flag_tmaxw .EQ. 1 ) ) THEN
1715 CALL t_to_theta ( grid%tmaxw , grid%pmaxw , p00 , &
1716 ids , ide , jds , jde , 1 , 1 , &
1717 ims , ime , jms , jme , 1 , 1 , &
1718 its , ite , jts , jte , 1 , 1 )
1719 END IF
1721 IF ( ( config_flags%interp_theta ) .AND. ( flag_ttrop .EQ. 1 ) ) THEN
1722 CALL t_to_theta ( grid%ttrop , grid%ptrop , p00 , &
1723 ids , ide , jds , jde , 1 , 1 , &
1724 ims , ime , jms , jme , 1 , 1 , &
1725 its , ite , jts , jte , 1 , 1 )
1726 END IF
1728 ! Depending on the setting of interp_theta = T/F, t_gc is is either theta Xor
1729 ! temperature, and that means that the t_2 field is also the associated field.
1730 ! It is better to interpolate temperature and potential temperature in LOG(p),
1731 ! regardless of requested default.
1733 interp_type = 2
1734 CALL vert_interp ( grid%t_gc , grid%pd_gc , grid%t_2 , grid%pb , &
1735 grid%tmaxw , grid%ttrop , grid%pmaxw , grid%ptrop , &
1736 grid%pmaxwnn , grid%ptropnn , &
1737 flag_tmaxw , flag_ttrop , &
1738 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1739 config_flags%maxw_above_this_level , &
1740 num_metgrid_levels , 'T' , &
1741 interp_type , lagrange_order , t_extrap_type , &
1742 lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
1743 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1744 ids , ide , jds , jde , kds , kde , &
1745 ims , ime , jms , jme , kms , kme , &
1746 its , ite , jts , jte , kts , kte )
1747 interp_type = grid%interp_type
1749 ! It is better to interpolate pressure in p regardless of the default options
1751 interp_type = 1
1752 CALL vert_interp ( grid%p_gc , grid%pd_gc , grid%p , grid%pb , &
1753 grid%pmaxw , grid%ptrop , grid%pmaxw , grid%ptrop , &
1754 grid%pmaxwnn , grid%ptropnn , &
1755 flag_pmaxw , flag_ptrop , &
1756 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1757 config_flags%maxw_above_this_level , &
1758 num_metgrid_levels , 'T' , &
1759 interp_type , lagrange_order , t_extrap_type , &
1760 lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
1761 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1762 ids , ide , jds , jde , kds , kde , &
1763 ims , ime , jms , jme , kms , kme , &
1764 its , ite , jts , jte , kts , kte )
1765 interp_type = grid%interp_type
1767 ! Do not have full pressure on eta levels, get a first guess at Qv by using
1768 ! dry pressure. The use of u_1 (rh) and v_1 (temperature) is temporary.
1769 ! We fix the approximation to Qv after the total pressure is available on
1770 ! eta surfaces.
1772 grid%v_1 = grid%t_2
1774 IF ( config_flags%interp_theta ) THEN
1775 CALL theta_to_t ( grid%v_1 , grid%p , p00 , &
1776 ids , ide , jds , jde , kds , kde , &
1777 ims , ime , jms , jme , kms , kme , &
1778 its , ite , jts , jte , kts , kte )
1779 END IF
1781 IF ( config_flags%rh2qv_method .eq. 1 ) THEN
1782 CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p , moist(:,:,:,P_QV) , &
1783 config_flags%rh2qv_wrt_liquid , &
1784 config_flags%qv_max_p_safe , &
1785 config_flags%qv_max_flag , config_flags%qv_max_value , &
1786 config_flags%qv_min_p_safe , &
1787 config_flags%qv_min_flag , config_flags%qv_min_value , &
1788 ids , ide , jds , jde , kds , kde , &
1789 ims , ime , jms , jme , kms , kme , &
1790 its , ite , jts , jte , kts , kte-1 )
1791 ELSE IF ( config_flags%rh2qv_method .eq. 2 ) THEN
1792 CALL rh_to_mxrat2(grid%u_1, grid%v_1, grid%p , moist(:,:,:,P_QV) , &
1793 config_flags%rh2qv_wrt_liquid , &
1794 config_flags%qv_max_p_safe , &
1795 config_flags%qv_max_flag , config_flags%qv_max_value , &
1796 config_flags%qv_min_p_safe , &
1797 config_flags%qv_min_flag , config_flags%qv_min_value , &
1798 ids , ide , jds , jde , kds , kde , &
1799 ims , ime , jms , jme , kms , kme , &
1800 its , ite , jts , jte , kts , kte-1 )
1801 END IF
1803 IF ( .NOT. config_flags%interp_theta ) THEN
1804 CALL t_to_theta ( grid%t_2 , grid%p , p00 , &
1805 ids , ide , jds , jde , kds , kde , &
1806 ims , ime , jms , jme , kms , kme , &
1807 its , ite , jts , jte , kts , kte-1 )
1808 END IF
1810 num_3d_m = num_moist
1811 num_3d_s = num_scalar
1813 IF ( flag_qr .EQ. 1 ) THEN
1814 DO im = PARAM_FIRST_SCALAR, num_3d_m
1815 IF ( im .EQ. P_QR ) THEN
1816 CALL vert_interp ( grid%qr_gc , grid%pd_gc , moist(:,:,:,P_QR) , grid%pb , &
1817 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1818 grid%pmaxwnn , grid%ptropnn , &
1819 0 , 0 , &
1820 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1821 config_flags%maxw_above_this_level , &
1822 num_metgrid_levels , 'Q' , &
1823 interp_type , linear_interp , extrap_type , &
1824 .false. , use_levels_below_ground , use_surface , &
1825 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1826 ids , ide , jds , jde , kds , kde , &
1827 ims , ime , jms , jme , kms , kme , &
1828 its , ite , jts , jte , kts , kte )
1829 END IF
1830 END DO
1831 END IF
1833 IF ( ( flag_qc .EQ. 1 ) .OR. ( flag_speccldl .EQ. 1 ) ) THEN
1834 DO im = PARAM_FIRST_SCALAR, num_3d_m
1835 IF ( im .EQ. P_QC ) THEN
1836 IF ( flag_speccldl .EQ. 1 ) THEN
1837 DO j = jts, MIN(jte,jde-1)
1838 DO k = 1 , num_metgrid_levels
1839 DO i = its, MIN(ite,ide-1)
1840 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1841 grid%qc_gc(i,k,j) = grid%cl_gc(i,k,j) /( 1. - grid%cl_gc(i,k,j) )
1842 END DO
1843 END DO
1844 END DO
1845 END IF
1846 CALL vert_interp ( grid%qc_gc , grid%pd_gc , moist(:,:,:,P_QC) , grid%pb , &
1847 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1848 grid%pmaxwnn , grid%ptropnn , &
1849 0 , 0 , &
1850 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1851 config_flags%maxw_above_this_level , &
1852 num_metgrid_levels , 'Q' , &
1853 interp_type , linear_interp , extrap_type , &
1854 .false. , use_levels_below_ground , use_surface , &
1855 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1856 ids , ide , jds , jde , kds , kde , &
1857 ims , ime , jms , jme , kms , kme , &
1858 its , ite , jts , jte , kts , kte )
1859 END IF
1860 END DO
1861 END IF
1863 IF ( ( flag_qi .EQ. 1 ) .OR. ( flag_speccldf .EQ. 1 ) ) THEN
1864 DO im = PARAM_FIRST_SCALAR, num_3d_m
1865 IF ( im .EQ. P_QI ) THEN
1866 IF ( flag_speccldf .EQ. 1 ) THEN
1867 DO j = jts, MIN(jte,jde-1)
1868 DO k = 1 , num_metgrid_levels
1869 DO i = its, MIN(ite,ide-1)
1870 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
1871 grid%qi_gc(i,k,j) = grid%cf_gc(i,k,j) /( 1. - grid%cf_gc(i,k,j) )
1872 END DO
1873 END DO
1874 END DO
1875 END IF
1876 CALL vert_interp ( grid%qi_gc , grid%pd_gc , moist(:,:,:,P_QI) , grid%pb , &
1877 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1878 grid%pmaxwnn , grid%ptropnn , &
1879 0 , 0 , &
1880 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1881 config_flags%maxw_above_this_level , &
1882 num_metgrid_levels , 'Q' , &
1883 interp_type , linear_interp , extrap_type , &
1884 .false. , use_levels_below_ground , use_surface , &
1885 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1886 ids , ide , jds , jde , kds , kde , &
1887 ims , ime , jms , jme , kms , kme , &
1888 its , ite , jts , jte , kts , kte )
1889 END IF
1890 END DO
1891 END IF
1893 IF ( flag_qs .EQ. 1 ) THEN
1894 DO im = PARAM_FIRST_SCALAR, num_3d_m
1895 IF ( im .EQ. P_QS ) THEN
1896 CALL vert_interp ( grid%qs_gc , grid%pd_gc , moist(:,:,:,P_QS) , grid%pb , &
1897 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1898 grid%pmaxwnn , grid%ptropnn , &
1899 0 , 0 , &
1900 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1901 config_flags%maxw_above_this_level , &
1902 num_metgrid_levels , 'Q' , &
1903 interp_type , linear_interp , extrap_type , &
1904 .false. , use_levels_below_ground , use_surface , &
1905 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1906 ids , ide , jds , jde , kds , kde , &
1907 ims , ime , jms , jme , kms , kme , &
1908 its , ite , jts , jte , kts , kte )
1909 END IF
1910 END DO
1911 END IF
1913 IF ( flag_qg .EQ. 1 ) THEN
1914 DO im = PARAM_FIRST_SCALAR, num_3d_m
1915 IF ( im .EQ. P_QG ) THEN
1916 CALL vert_interp ( grid%qg_gc , grid%pd_gc , moist(:,:,:,P_QG) , grid%pb , &
1917 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1918 grid%pmaxwnn , grid%ptropnn , &
1919 0 , 0 , &
1920 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1921 config_flags%maxw_above_this_level , &
1922 num_metgrid_levels , 'Q' , &
1923 interp_type , linear_interp , extrap_type , &
1924 .false. , use_levels_below_ground , use_surface , &
1925 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1926 ids , ide , jds , jde , kds , kde , &
1927 ims , ime , jms , jme , kms , kme , &
1928 its , ite , jts , jte , kts , kte )
1929 END IF
1930 END DO
1931 END IF
1933 IF ( flag_qh .EQ. 1 ) THEN
1934 DO im = PARAM_FIRST_SCALAR, num_3d_m
1935 IF ( im .EQ. P_QH ) THEN
1936 CALL vert_interp ( grid%qh_gc , grid%pd_gc , moist(:,:,:,P_QH) , grid%pb , &
1937 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1938 grid%pmaxwnn , grid%ptropnn , &
1939 0 , 0 , &
1940 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1941 config_flags%maxw_above_this_level , &
1942 num_metgrid_levels , 'Q' , &
1943 interp_type , linear_interp , extrap_type , &
1944 .false. , use_levels_below_ground , use_surface , &
1945 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1946 ids , ide , jds , jde , kds , kde , &
1947 ims , ime , jms , jme , kms , kme , &
1948 its , ite , jts , jte , kts , kte )
1949 END IF
1950 END DO
1951 END IF
1953 IF ( flag_qni .EQ. 1 ) THEN
1954 DO im = PARAM_FIRST_SCALAR, num_3d_s
1955 IF ( im .EQ. P_QNI ) THEN
1956 CALL vert_interp ( grid%qni_gc , grid%pd_gc , scalar(:,:,:,P_QNI) , grid%pb , &
1957 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1958 grid%pmaxwnn , grid%ptropnn , &
1959 0 , 0 , &
1960 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1961 config_flags%maxw_above_this_level , &
1962 num_metgrid_levels , 'Q' , &
1963 interp_type , linear_interp , extrap_type , &
1964 .false. , use_levels_below_ground , use_surface , &
1965 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1966 ids , ide , jds , jde , kds , kde , &
1967 ims , ime , jms , jme , kms , kme , &
1968 its , ite , jts , jte , kts , kte )
1969 END IF
1970 END DO
1971 END IF
1973 IF ( flag_qnc .EQ. 1 ) THEN
1974 DO im = PARAM_FIRST_SCALAR, num_3d_s
1975 IF ( im .EQ. P_QNC ) THEN
1976 CALL vert_interp ( grid%qnc_gc , grid%pd_gc , scalar(:,:,:,P_QNC) , grid%pb , &
1977 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1978 grid%pmaxwnn , grid%ptropnn , &
1979 0 , 0 , &
1980 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
1981 config_flags%maxw_above_this_level , &
1982 num_metgrid_levels , 'Q' , &
1983 interp_type , linear_interp , extrap_type , &
1984 .false. , use_levels_below_ground , use_surface , &
1985 zap_close_levels , force_sfc_in_vinterp , grid%id , &
1986 ids , ide , jds , jde , kds , kde , &
1987 ims , ime , jms , jme , kms , kme , &
1988 its , ite , jts , jte , kts , kte )
1989 END IF
1990 END DO
1991 END IF
1993 IF ( flag_qnr .EQ. 1 ) THEN
1994 DO im = PARAM_FIRST_SCALAR, num_3d_s
1995 IF ( im .EQ. P_QNR ) THEN
1996 CALL vert_interp ( grid%qnr_gc , grid%pd_gc , scalar(:,:,:,P_QNR) , grid%pb , &
1997 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
1998 grid%pmaxwnn , grid%ptropnn , &
1999 0 , 0 , &
2000 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2001 config_flags%maxw_above_this_level , &
2002 num_metgrid_levels , 'Q' , &
2003 interp_type , linear_interp , extrap_type , &
2004 .false. , use_levels_below_ground , use_surface , &
2005 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2006 ids , ide , jds , jde , kds , kde , &
2007 ims , ime , jms , jme , kms , kme , &
2008 its , ite , jts , jte , kts , kte )
2009 END IF
2010 END DO
2011 END IF
2013 IF ( flag_qns .EQ. 1 ) THEN
2014 DO im = PARAM_FIRST_SCALAR, num_3d_s
2015 IF ( im .EQ. P_QNS ) THEN
2016 CALL vert_interp ( grid%qns_gc , grid%pd_gc , scalar(:,:,:,P_QNS) , grid%pb , &
2017 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2018 grid%pmaxwnn , grid%ptropnn , &
2019 0 , 0 , &
2020 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2021 config_flags%maxw_above_this_level , &
2022 num_metgrid_levels , 'Q' , &
2023 interp_type , linear_interp , extrap_type , &
2024 .false. , use_levels_below_ground , use_surface , &
2025 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2026 ids , ide , jds , jde , kds , kde , &
2027 ims , ime , jms , jme , kms , kme , &
2028 its , ite , jts , jte , kts , kte )
2029 END IF
2030 END DO
2031 END IF
2033 IF ( flag_qng .EQ. 1 ) THEN
2034 DO im = PARAM_FIRST_SCALAR, num_3d_s
2035 IF ( im .EQ. P_QNG ) THEN
2036 CALL vert_interp ( grid%qng_gc , grid%pd_gc , scalar(:,:,:,P_QNG) , grid%pb , &
2037 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2038 grid%pmaxwnn , grid%ptropnn , &
2039 0 , 0 , &
2040 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2041 config_flags%maxw_above_this_level , &
2042 num_metgrid_levels , 'Q' , &
2043 interp_type , linear_interp , extrap_type , &
2044 .false. , use_levels_below_ground , use_surface , &
2045 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2046 ids , ide , jds , jde , kds , kde , &
2047 ims , ime , jms , jme , kms , kme , &
2048 its , ite , jts , jte , kts , kte )
2049 END IF
2050 END DO
2051 END IF
2053 IF ( flag_qnh .EQ. 1 ) THEN
2054 DO im = PARAM_FIRST_SCALAR, num_3d_s
2055 IF ( im .EQ. P_QNH ) THEN
2056 CALL vert_interp ( grid%qnh_gc , grid%pd_gc , scalar(:,:,:,P_QNH) , grid%pb , &
2057 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2058 grid%pmaxwnn , grid%ptropnn , &
2059 0 , 0 , &
2060 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2061 config_flags%maxw_above_this_level , &
2062 num_metgrid_levels , 'Q' , &
2063 interp_type , linear_interp , extrap_type , &
2064 .false. , use_levels_below_ground , use_surface , &
2065 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2066 ids , ide , jds , jde , kds , kde , &
2067 ims , ime , jms , jme , kms , kme , &
2068 its , ite , jts , jte , kts , kte )
2069 END IF
2070 END DO
2071 END IF
2073 !=========================================================================================
2074 ! START OF OPTIONAL 3D DATA, USUALLY AEROSOLS
2075 !=========================================================================================
2077 #if ( WRF_CHEM == 1 )
2078 ! Do we have the old data that came in on the same vertical levels as the other
2079 ! met variables? If so, we can skip all of this interpolation, as the pressure field
2080 ! is allocated, but all zeros.
2082 IF ( config_flags%gca_input_opt .EQ. 1 ) THEN
2083 IF ( ( config_flags%num_gca_levels .GT. 0 ) .AND. &
2084 ( ABS(grid %p_gca(its,config_flags%num_gca_levels/2,jts)) .GT. 1 ) ) THEN
2086 ! Insert source code here to vertically interpolate an extra set of 3d arrays
2087 ! that could be on a different vertical structure than the input atmospheric
2088 ! data. Mostly, this is expected to be for monthly data (such as background
2089 ! aerosol information).
2091 ! OPTIONAL DATA #1: GCA - Go Cart Aerosols: OH, H2O2, NO3
2092 ! Pressure name: p_gca
2093 ! Number of vertical levels: num_gca_levels
2094 ! Variable names (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): oh, h2o2, no3
2095 ! Option to interpolate data: gca_input_opt = 1
2096 ! Not stored in scalar arrays.
2098 IF ( config_flags%gca_input_opt .EQ. 1 ) THEN
2100 CALL wrf_debug ( 0 , 'Using monthly GOcart Aerosol input: OH, H2O2, NO3 from metgrid input file' )
2102 ! There are three fields - they are 3d, so no easy way to loop over them.
2103 ! OH - Hydroxyl
2104 ! H2O2 - Hydrogen Peroxide
2105 ! NO3 - Nitrate
2107 DO k = 1, config_flags%num_gca_levels
2108 WRITE(a_message,*) ' transferring each K-level ', k, ' to OH, sample Jan data, ', grid % oh_gca_jan(its,k,jts)
2109 CALL wrf_debug ( 1 , a_message)
2110 DO j = jts, MIN(jte,jde-1)
2111 DO i = its, MIN(ite,ide-1)
2112 grid%qntemp(i, 1, j) = grid % oh_gca_jan(i,k,j)
2113 grid%qntemp(i, 2, j) = grid % oh_gca_feb(i,k,j)
2114 grid%qntemp(i, 3, j) = grid % oh_gca_mar(i,k,j)
2115 grid%qntemp(i, 4, j) = grid % oh_gca_apr(i,k,j)
2116 grid%qntemp(i, 5, j) = grid % oh_gca_may(i,k,j)
2117 grid%qntemp(i, 6, j) = grid % oh_gca_jun(i,k,j)
2118 grid%qntemp(i, 7, j) = grid % oh_gca_jul(i,k,j)
2119 grid%qntemp(i, 8, j) = grid % oh_gca_aug(i,k,j)
2120 grid%qntemp(i, 9, j) = grid % oh_gca_sep(i,k,j)
2121 grid%qntemp(i,10, j) = grid % oh_gca_oct(i,k,j)
2122 grid%qntemp(i,11, j) = grid % oh_gca_nov(i,k,j)
2123 grid%qntemp(i,12, j) = grid % oh_gca_dec(i,k,j)
2124 END DO
2125 END DO
2126 IF ( k .EQ. 1 ) THEN
2127 WRITE(a_message,*) ' GOcart Aerosols OH (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts)
2128 CALL wrf_debug ( 1 , a_message)
2129 END IF
2130 CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2131 ids , ide , jds , jde , kds , kde , &
2132 ims , ime , jms , jme , kms , kme , &
2133 its , ite , jts , jte , kts , kte )
2134 IF ( k .eq. 1 ) THEN
2135 write(a_message,*) ' GOcart Aerosols OH (now) ', grid%qntemp2(its,jts)
2136 CALL wrf_debug ( 1 , a_message)
2137 END IF
2138 DO j = jts, MIN(jte,jde-1)
2139 DO i = its, MIN(ite,ide-1)
2140 grid % oh_gca_now(i,k,j) = grid%qntemp2(i,j)
2141 END DO
2142 END DO
2143 END DO
2145 CALL vert_interp ( grid % oh_gca_now , grid%p_gca , grid%backg_oh , grid%pb , &
2146 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2147 grid%pmaxwnn , grid%ptropnn , &
2148 0 , 0 , &
2149 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2150 config_flags%maxw_above_this_level , &
2151 config_flags%num_gca_levels , 'Q' , &
2152 interp_type , linear_interp , extrap_type , &
2153 .false. , use_levels_below_ground , use_surface , &
2154 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2155 ids , ide , jds , jde , kds , kde , &
2156 ims , ime , jms , jme , kms , kme , &
2157 its , ite , jts , jte , kts , kte )
2159 DO k = 1, config_flags%num_gca_levels
2160 WRITE(a_message,*) ' transferring each K-level ', k, ' to H2O2, sample Jan data, ', grid %h2o2_gca_jan(its,k,jts)
2161 CALL wrf_debug ( 1 , a_message)
2162 DO j = jts, MIN(jte,jde-1)
2163 DO i = its, MIN(ite,ide-1)
2164 grid%qntemp(i, 1, j) = grid %h2o2_gca_jan(i,k,j)
2165 grid%qntemp(i, 2, j) = grid %h2o2_gca_feb(i,k,j)
2166 grid%qntemp(i, 3, j) = grid %h2o2_gca_mar(i,k,j)
2167 grid%qntemp(i, 4, j) = grid %h2o2_gca_apr(i,k,j)
2168 grid%qntemp(i, 5, j) = grid %h2o2_gca_may(i,k,j)
2169 grid%qntemp(i, 6, j) = grid %h2o2_gca_jun(i,k,j)
2170 grid%qntemp(i, 7, j) = grid %h2o2_gca_jul(i,k,j)
2171 grid%qntemp(i, 8, j) = grid %h2o2_gca_aug(i,k,j)
2172 grid%qntemp(i, 9, j) = grid %h2o2_gca_sep(i,k,j)
2173 grid%qntemp(i,10, j) = grid %h2o2_gca_oct(i,k,j)
2174 grid%qntemp(i,11, j) = grid %h2o2_gca_nov(i,k,j)
2175 grid%qntemp(i,12, j) = grid %h2o2_gca_dec(i,k,j)
2176 END DO
2177 END DO
2178 IF ( k .EQ. 1 ) THEN
2179 WRITE(a_message,*) ' GOcart Aerosols H2O2 (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts)
2180 CALL wrf_debug ( 1 , a_message)
2181 END IF
2182 CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2183 ids , ide , jds , jde , kds , kde , &
2184 ims , ime , jms , jme , kms , kme , &
2185 its , ite , jts , jte , kts , kte )
2186 IF ( k .eq. 1 ) THEN
2187 write(a_message,*) ' GOcart Aerosols H2O2 (now) ', grid%qntemp2(its,jts)
2188 CALL wrf_debug ( 1 , a_message)
2189 END IF
2190 DO j = jts, MIN(jte,jde-1)
2191 DO i = its, MIN(ite,ide-1)
2192 grid %h2o2_gca_now(i,k,j) = grid%qntemp2(i,j)
2193 END DO
2194 END DO
2195 END DO
2197 CALL vert_interp ( grid %h2o2_gca_now , grid%p_gca , grid%backg_h2o2 , grid%pb , &
2198 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2199 grid%pmaxwnn , grid%ptropnn , &
2200 0 , 0 , &
2201 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2202 config_flags%maxw_above_this_level , &
2203 config_flags%num_gca_levels , 'Q' , &
2204 interp_type , linear_interp , extrap_type , &
2205 .false. , use_levels_below_ground , use_surface , &
2206 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2207 ids , ide , jds , jde , kds , kde , &
2208 ims , ime , jms , jme , kms , kme , &
2209 its , ite , jts , jte , kts , kte )
2211 DO k = 1, config_flags%num_gca_levels
2212 WRITE(a_message,*) ' transferring each K-level ', k, ' to NO3, sample Jan data, ', grid % no3_gca_jan(its,k,jts)
2213 CALL wrf_debug ( 1 , a_message)
2214 DO j = jts, MIN(jte,jde-1)
2215 DO i = its, MIN(ite,ide-1)
2216 grid%qntemp(i, 1, j) = grid % no3_gca_jan(i,k,j)
2217 grid%qntemp(i, 2, j) = grid % no3_gca_feb(i,k,j)
2218 grid%qntemp(i, 3, j) = grid % no3_gca_mar(i,k,j)
2219 grid%qntemp(i, 4, j) = grid % no3_gca_apr(i,k,j)
2220 grid%qntemp(i, 5, j) = grid % no3_gca_may(i,k,j)
2221 grid%qntemp(i, 6, j) = grid % no3_gca_jun(i,k,j)
2222 grid%qntemp(i, 7, j) = grid % no3_gca_jul(i,k,j)
2223 grid%qntemp(i, 8, j) = grid % no3_gca_aug(i,k,j)
2224 grid%qntemp(i, 9, j) = grid % no3_gca_sep(i,k,j)
2225 grid%qntemp(i,10, j) = grid % no3_gca_oct(i,k,j)
2226 grid%qntemp(i,11, j) = grid % no3_gca_nov(i,k,j)
2227 grid%qntemp(i,12, j) = grid % no3_gca_dec(i,k,j)
2228 END DO
2229 END DO
2230 IF ( k .EQ. 1 ) THEN
2231 WRITE(a_message,*) ' GOcart Aerosols NO3 (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts)
2232 CALL wrf_debug ( 1 , a_message)
2233 END IF
2234 CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2235 ids , ide , jds , jde , kds , kde , &
2236 ims , ime , jms , jme , kms , kme , &
2237 its , ite , jts , jte , kts , kte )
2238 IF ( k .eq. 1 ) THEN
2239 write(a_message,*) ' GOcart Aerosols NO3 (now) ', grid%qntemp2(its,jts)
2240 CALL wrf_debug ( 1 , a_message)
2241 END IF
2242 DO j = jts, MIN(jte,jde-1)
2243 DO i = its, MIN(ite,ide-1)
2244 grid % no3_gca_now(i,k,j) = grid%qntemp2(i,j)
2245 END DO
2246 END DO
2247 END DO
2249 CALL vert_interp ( grid % no3_gca_now , grid%p_gca , grid%backg_no3 , grid%pb , &
2250 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2251 grid%pmaxwnn , grid%ptropnn , &
2252 0 , 0 , &
2253 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2254 config_flags%maxw_above_this_level , &
2255 config_flags%num_gca_levels , 'Q' , &
2256 interp_type , linear_interp , extrap_type , &
2257 .false. , use_levels_below_ground , use_surface , &
2258 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2259 ids , ide , jds , jde , kds , kde , &
2260 ims , ime , jms , jme , kms , kme , &
2261 its , ite , jts , jte , kts , kte )
2262 END IF
2263 END IF
2264 END IF
2265 #endif
2267 ! OPTIONAL DATA #2: Thompson Water-Friendly Ice-Friendly Aerosols
2268 ! Pressure name (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): p_wif
2269 ! Number of vertical levels: num_wif_levels
2270 ! Variable names (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): w_wif, i_wif
2271 ! Option to interpolate data: wif_input_opt = 1 (water and ice friendly aerosols)
2272 ! = 2 (water and ice friendly + black carbon aerosols)
2273 ! Stored in scalar arrays, tested and assumed to be upside down.
2274 ! There are two data fields plus pressure - they are 3d, so no easy way to loop over them.
2275 ! QNWFA - Number concentration water-friendly aerosols
2276 ! QNIFA - Number concentration ice-friendly aerosols
2277 ! QNBCA - Number concentration black carbon aerosols
2279 aer_init_opt = config_flags%aer_init_opt
2281 if_thompsonaero_3d: IF (config_flags%mp_physics .EQ. THOMPSONAERO .AND. &
2282 config_flags%wif_input_opt .GT. 0) THEN
2284 select_aer_init_opt_3d: select case (aer_init_opt)
2286 case (0) ! Initialize to zero
2288 CALL wrf_debug (0 , 'COMMENT: QNWFA and QNIFA will be initialized to zero values')
2289 DO im = PARAM_FIRST_SCALAR, num_3d_s
2290 IF ( im .EQ. P_QNWFA .or. im .EQ. P_QNIFA) THEN
2291 DO j = jts, MIN(jte,jde-1)
2292 DO k = kts, kte
2293 DO i = its, MIN(ite,ide-1)
2294 scalar(i,k,j,im) = 0.0
2295 END DO
2296 END DO
2297 END DO
2298 END IF
2299 END DO
2301 case (1) ! Monthly climatology (GOCART, etc.)
2303 CALL wrf_debug (0 , 'COMMENT: Using monthly climatology aerosols')
2305 ! First, get the pressure temporally interpolated to the correct date/time since
2306 ! this is a hybrid coordinate (not isobaric), and the pressure changes by month.
2307 ! NOTE: The input pressure is not vertically interpolated, but the other two input
2308 ! fields (QNWFA, QNIFA) are interpolated to the WRF eta coordinate.
2310 do_pres_cl: if (flag_qnwfa_cl .EQ. 1 .and. flag_qnifa_cl .EQ. 1) then
2311 if (config_flags%num_wif_levels .EQ. num_wif_levels_default) then
2312 IF ( grid%p_wif_jan(its,config_flags%num_wif_levels/2-1,jts) - &
2313 grid%p_wif_jan(its,config_flags%num_wif_levels/2+1,jts) .LT. 0 ) THEN
2314 wif_upside_down = .TRUE.
2315 END IF
2317 DO k = 1, config_flags%num_wif_levels
2318 DO j = jts, MIN(jte,jde-1)
2319 DO i = its, MIN(ite,ide-1)
2320 grid%qntemp(i, 1, j) = grid %p_wif_jan(i,k,j)
2321 grid%qntemp(i, 2, j) = grid %p_wif_feb(i,k,j)
2322 grid%qntemp(i, 3, j) = grid %p_wif_mar(i,k,j)
2323 grid%qntemp(i, 4, j) = grid %p_wif_apr(i,k,j)
2324 grid%qntemp(i, 5, j) = grid %p_wif_may(i,k,j)
2325 grid%qntemp(i, 6, j) = grid %p_wif_jun(i,k,j)
2326 grid%qntemp(i, 7, j) = grid %p_wif_jul(i,k,j)
2327 grid%qntemp(i, 8, j) = grid %p_wif_aug(i,k,j)
2328 grid%qntemp(i, 9, j) = grid %p_wif_sep(i,k,j)
2329 grid%qntemp(i,10, j) = grid %p_wif_oct(i,k,j)
2330 grid%qntemp(i,11, j) = grid %p_wif_nov(i,k,j)
2331 grid%qntemp(i,12, j) = grid %p_wif_dec(i,k,j)
2332 END DO
2333 END DO
2334 CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2335 ids , ide , jds , jde , kds , kde , &
2336 ims , ime , jms , jme , kms , kme , &
2337 its , ite , jts , jte , kts , kte )
2338 IF ( wif_upside_down ) THEN
2339 DO j = jts, MIN(jte,jde-1)
2340 DO i = its, MIN(ite,ide-1)
2341 grid %p_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j)
2342 END DO
2343 END DO
2344 ELSE IF ( .NOT. wif_upside_down ) THEN
2345 DO j = jts, MIN(jte,jde-1)
2346 DO i = its, MIN(ite,ide-1)
2347 grid %p_wif_now(i, k,j) = grid%qntemp2(i,j)
2348 END DO
2349 END DO
2350 END IF
2351 END DO
2352 else
2353 CALL wrf_error_fatal ('mp_physics=28 and use_aero_icbc=.true. but wrong num_wif_levels, please set =30')
2354 end if
2355 else
2356 CALL wrf_error_fatal ('mp_physics=28 and use_aero_icbc=.true. but aerosol climatology field(s) missing' )
2357 end if do_pres_cl
2359 ! Water-friendly aerosol
2360 do_qnwfa_cl: if (flag_qnwfa_cl .EQ. 1) then
2361 DO k = 1, config_flags%num_wif_levels
2362 DO j = jts, MIN(jte,jde-1)
2363 DO i = its, MIN(ite,ide-1)
2364 grid%qntemp(i, 1, j) = grid %w_wif_jan(i,k,j)
2365 grid%qntemp(i, 2, j) = grid %w_wif_feb(i,k,j)
2366 grid%qntemp(i, 3, j) = grid %w_wif_mar(i,k,j)
2367 grid%qntemp(i, 4, j) = grid %w_wif_apr(i,k,j)
2368 grid%qntemp(i, 5, j) = grid %w_wif_may(i,k,j)
2369 grid%qntemp(i, 6, j) = grid %w_wif_jun(i,k,j)
2370 grid%qntemp(i, 7, j) = grid %w_wif_jul(i,k,j)
2371 grid%qntemp(i, 8, j) = grid %w_wif_aug(i,k,j)
2372 grid%qntemp(i, 9, j) = grid %w_wif_sep(i,k,j)
2373 grid%qntemp(i,10, j) = grid %w_wif_oct(i,k,j)
2374 grid%qntemp(i,11, j) = grid %w_wif_nov(i,k,j)
2375 grid%qntemp(i,12, j) = grid %w_wif_dec(i,k,j)
2376 END DO
2377 END DO
2378 CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2379 ids , ide , jds , jde , kds , kde , &
2380 ims , ime , jms , jme , kms , kme , &
2381 its , ite , jts , jte , kts , kte )
2382 IF ( wif_upside_down ) THEN
2383 DO j = jts, MIN(jte,jde-1)
2384 DO i = its, MIN(ite,ide-1)
2385 grid %w_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j)
2386 END DO
2387 END DO
2388 ELSE IF ( .NOT. wif_upside_down ) THEN
2389 DO j = jts, MIN(jte,jde-1)
2390 DO i = its, MIN(ite,ide-1)
2391 grid %w_wif_now(i, k,j) = grid%qntemp2(i,j)
2392 END DO
2393 END DO
2394 END IF
2395 END DO
2397 CALL wrf_debug (0 , 'Vertically-interpolating QNWFA climatology from WPS data to fill scalar')
2398 CALL vert_interp ( grid %w_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnwfa) , grid%pb , &
2399 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2400 grid%pmaxwnn , grid%ptropnn , &
2401 0 , 0 , &
2402 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2403 config_flags%maxw_above_this_level , &
2404 config_flags%num_wif_levels , 'Q' , &
2405 interp_type , linear_interp , extrap_type , &
2406 .false. , use_levels_below_ground , use_surface , &
2407 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2408 ids , ide , jds , jde , kds , kde , &
2409 ims , ime , jms , jme , kms , kme , &
2410 its , ite , jts , jte , kts , kte )
2411 else
2412 CALL wrf_error_fatal ('mp_physics=28 but there is not QNWFA aerosol information from climatology' )
2413 end if do_qnwfa_cl
2415 ! Ice-friendly aerosol
2416 do_qnifa_cl: if (flag_qnifa_cl .EQ. 1) then
2417 DO k = 1, config_flags%num_wif_levels
2418 WRITE(a_message,*) ' transferring each K-level ', k, ' to QNIFA, sample Jan data, ', grid %i_wif_jan(its,k,jts)
2419 CALL wrf_debug ( 1 , a_message)
2420 DO j = jts, MIN(jte,jde-1)
2421 DO i = its, MIN(ite,ide-1)
2422 grid%qntemp(i, 1, j) = grid %i_wif_jan(i,k,j)
2423 grid%qntemp(i, 2, j) = grid %i_wif_feb(i,k,j)
2424 grid%qntemp(i, 3, j) = grid %i_wif_mar(i,k,j)
2425 grid%qntemp(i, 4, j) = grid %i_wif_apr(i,k,j)
2426 grid%qntemp(i, 5, j) = grid %i_wif_may(i,k,j)
2427 grid%qntemp(i, 6, j) = grid %i_wif_jun(i,k,j)
2428 grid%qntemp(i, 7, j) = grid %i_wif_jul(i,k,j)
2429 grid%qntemp(i, 8, j) = grid %i_wif_aug(i,k,j)
2430 grid%qntemp(i, 9, j) = grid %i_wif_sep(i,k,j)
2431 grid%qntemp(i,10, j) = grid %i_wif_oct(i,k,j)
2432 grid%qntemp(i,11, j) = grid %i_wif_nov(i,k,j)
2433 grid%qntemp(i,12, j) = grid %i_wif_dec(i,k,j)
2434 END DO
2435 END DO
2436 IF ( k .EQ. 1 ) THEN
2437 WRITE(a_message,*) ' QNIFA (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts)
2438 CALL wrf_debug ( 1 , a_message)
2439 END IF
2440 CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2441 ids , ide , jds , jde , kds , kde , &
2442 ims , ime , jms , jme , kms , kme , &
2443 its , ite , jts , jte , kts , kte )
2444 IF ( k .eq. 1 ) THEN
2445 write(a_message,*) ' QNIFA (now) ', grid%qntemp2(its,jts)
2446 CALL wrf_debug ( 1 , a_message)
2447 END IF
2448 IF ( wif_upside_down ) THEN
2449 DO j = jts, MIN(jte,jde-1)
2450 DO i = its, MIN(ite,ide-1)
2451 grid %i_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j)
2452 END DO
2453 END DO
2454 ELSE IF ( .NOT. wif_upside_down ) THEN
2455 DO j = jts, MIN(jte,jde-1)
2456 DO i = its, MIN(ite,ide-1)
2457 grid %i_wif_now(i, k,j) = grid%qntemp2(i,j)
2458 END DO
2459 END DO
2460 END IF
2461 END DO
2463 CALL wrf_debug (0 , 'Vertically-interpolating QNIFA climatology from WPS data to fill scalar')
2464 CALL vert_interp ( grid %i_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnifa) , grid%pb , &
2465 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2466 grid%pmaxwnn , grid%ptropnn , &
2467 0 , 0 , &
2468 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2469 config_flags%maxw_above_this_level , &
2470 config_flags%num_wif_levels , 'Q' , &
2471 interp_type , linear_interp , extrap_type , &
2472 .false. , use_levels_below_ground , use_surface , &
2473 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2474 ids , ide , jds , jde , kds , kde , &
2475 ims , ime , jms , jme , kms , kme , &
2476 its , ite , jts , jte , kts , kte )
2477 else
2478 CALL wrf_error_fatal ('mp_physics=28 but there is not QNIFA aerosol information from climatology' )
2479 end if do_qnifa_cl
2481 ! Black carbon aerosol
2482 if (config_flags%wif_input_opt .EQ. 2) then
2483 do_qnbca_cl: if (flag_qnbca_cl .EQ. 1) then
2484 DO k = 1, config_flags%num_wif_levels
2485 WRITE(a_message,*) ' transferring each K-level ', k, ' to QNBCA, sample Jan data, ', grid %b_wif_jan(its,k,jts)
2486 CALL wrf_debug ( 1 , a_message)
2487 DO j = jts, MIN(jte,jde-1)
2488 DO i = its, MIN(ite,ide-1)
2489 grid%qntemp(i, 1, j) = grid %b_wif_jan(i,k,j)
2490 grid%qntemp(i, 2, j) = grid %b_wif_feb(i,k,j)
2491 grid%qntemp(i, 3, j) = grid %b_wif_mar(i,k,j)
2492 grid%qntemp(i, 4, j) = grid %b_wif_apr(i,k,j)
2493 grid%qntemp(i, 5, j) = grid %b_wif_may(i,k,j)
2494 grid%qntemp(i, 6, j) = grid %b_wif_jun(i,k,j)
2495 grid%qntemp(i, 7, j) = grid %b_wif_jul(i,k,j)
2496 grid%qntemp(i, 8, j) = grid %b_wif_aug(i,k,j)
2497 grid%qntemp(i, 9, j) = grid %b_wif_sep(i,k,j)
2498 grid%qntemp(i,10, j) = grid %b_wif_oct(i,k,j)
2499 grid%qntemp(i,11, j) = grid %b_wif_nov(i,k,j)
2500 grid%qntemp(i,12, j) = grid %b_wif_dec(i,k,j)
2501 END DO
2502 END DO
2503 IF ( k .EQ. 1 ) THEN
2504 WRITE(a_message,*) ' QNBCA (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts)
2505 CALL wrf_debug ( 1 , a_message)
2506 END IF
2507 CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , &
2508 ids , ide , jds , jde , kds , kde , &
2509 ims , ime , jms , jme , kms , kme , &
2510 its , ite , jts , jte , kts , kte )
2511 IF ( k .eq. 1 ) THEN
2512 write(a_message,*) ' QNBCA (now) ', grid%qntemp2(its,jts)
2513 CALL wrf_debug ( 1 , a_message)
2514 END IF
2515 IF ( wif_upside_down ) THEN
2516 DO j = jts, MIN(jte,jde-1)
2517 DO i = its, MIN(ite,ide-1)
2518 grid %b_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j)
2519 END DO
2520 END DO
2521 ELSE IF ( .NOT. wif_upside_down ) THEN
2522 DO j = jts, MIN(jte,jde-1)
2523 DO i = its, MIN(ite,ide-1)
2524 grid %b_wif_now(i, k,j) = grid%qntemp2(i,j)
2525 END DO
2526 END DO
2527 END IF
2528 END DO
2530 CALL wrf_debug (0 , 'Vertically-interpolating QNBCA climatology from WPS data to fill scalar')
2531 CALL vert_interp ( grid %b_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnbca) , grid%pb , &
2532 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2533 grid%pmaxwnn , grid%ptropnn , &
2534 0 , 0 , &
2535 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2536 config_flags%maxw_above_this_level , &
2537 config_flags%num_wif_levels , 'Q' , &
2538 interp_type , linear_interp , extrap_type , &
2539 .false. , use_levels_below_ground , use_surface , &
2540 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2541 ids , ide , jds , jde , kds , kde , &
2542 ims , ime , jms , jme , kms , kme , &
2543 its , ite , jts , jte , kts , kte )
2544 else
2545 CALL wrf_error_fatal ('mp_physics=28 and wif_input_opt=2 but there is not QNBCA aerosol information from climatology' )
2546 end if do_qnbca_cl
2547 end if
2549 case (2) ! First guess aerosol (GEOS-5, etc.)
2551 CALL wrf_debug (0 , 'COMMENT: Using first guess aerosols')
2553 ! Water-friendly aerosol
2554 do_qnwfa: if (flag_qnwfa .EQ. 1) then
2555 if (flag_p_wif .EQ. 1 ) then ! Interpolate according to native pressure field from aerosol forcing model
2556 CALL wrf_debug (0 , 'Vertically-interpolating QNWFA first guess from WPS data to fill scalar using native pressure field')
2557 CALL wrf_debug (0 , 'COMMENT: BE SURE num_wif_levels IN NAMELIST EQUALS num_wif_levels IN MET_EM FILES!')
2558 CALL vert_interp ( grid%qnwfa_gc , grid%p_wif_gc , scalar(:,:,:,P_QNWFA) , grid%pb , &
2559 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2560 grid%pmaxwnn , grid%ptropnn , &
2561 0 , 0 , &
2562 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2563 config_flags%maxw_above_this_level , &
2564 config_flags%num_wif_levels , 'Q' , &
2565 interp_type , linear_interp , extrap_type , &
2566 .false. , use_levels_below_ground , use_surface , &
2567 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2568 ids , ide , jds , jde , kds , kde , &
2569 ims , ime , jms , jme , kms , kme , &
2570 its , ite , jts , jte , kts , kte )
2571 else ! Interpolate according to metgrid pressure field
2572 if (config_flags%num_wif_levels .EQ. num_metgrid_levels) then ! Check to make sure that the number of aerosol levels is consistent with the metgrid pressure levels
2573 CALL wrf_debug (0 , 'Vertically-interpolating QNWFA first guess from WPS data to fill scalar using metgrid pressure field')
2574 CALL vert_interp ( grid%qnwfa_gc , grid%pd_gc , scalar(:,:,:,P_QNWFA) , grid%pb , &
2575 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2576 grid%pmaxwnn , grid%ptropnn , &
2577 0 , 0 , &
2578 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2579 config_flags%maxw_above_this_level , &
2580 config_flags%num_wif_levels , 'Q' , &
2581 interp_type , linear_interp , extrap_type , &
2582 .false. , use_levels_below_ground , use_surface , &
2583 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2584 ids , ide , jds , jde , kds , kde , &
2585 ims , ime , jms , jme , kms , kme , &
2586 its , ite , jts , jte , kts , kte )
2587 else
2588 CALL wrf_error_fatal ('num_wif_levels not equal to num_metgrid_levels')
2589 end if
2590 end if
2591 else
2592 CALL wrf_error_fatal ('mp_physics=28 but there is not QNWFA aerosol information from first guess' )
2593 end if do_qnwfa
2595 ! Ice-friendly aerosol
2596 do_qnifa: if (flag_qnifa .EQ. 1) then
2597 if (flag_p_wif .EQ. 1) then
2598 CALL wrf_debug (0 , 'Vertically-interpolating QNIFA first guess from WPS data to fill scalar using native pressure field')
2599 CALL wrf_debug (0 , 'COMMENT: BE SURE num_wif_levels IN NAMELIST EQUALS num_wif_levels IN MET_EM FILES!')
2600 CALL vert_interp ( grid%qnifa_gc , grid%p_wif_gc , scalar(:,:,:,P_QNIFA) , grid%pb , &
2601 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2602 grid%pmaxwnn , grid%ptropnn , &
2603 0 , 0 , &
2604 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2605 config_flags%maxw_above_this_level , &
2606 config_flags%num_wif_levels , 'Q' , &
2607 interp_type , linear_interp , extrap_type , &
2608 .false. , use_levels_below_ground , use_surface , &
2609 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2610 ids , ide , jds , jde , kds , kde , &
2611 ims , ime , jms , jme , kms , kme , &
2612 its , ite , jts , jte , kts , kte )
2613 else ! Interpolate according to metgrid pressure field
2614 if (config_flags%num_wif_levels .EQ. num_metgrid_levels) then ! Check to make sure that the number of aerosol levels is consistent with the metgrid pressure levels
2615 CALL wrf_debug (0 , 'Vertically-interpolating QNIFA first guess from WPS data to fill scalar using metgrid pressure field')
2616 CALL vert_interp ( grid%qnifa_gc , grid%pd_gc , scalar(:,:,:,P_QNIFA) , grid%pb , &
2617 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2618 grid%pmaxwnn , grid%ptropnn , &
2619 0 , 0 , &
2620 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2621 config_flags%maxw_above_this_level , &
2622 config_flags%num_wif_levels , 'Q' , &
2623 interp_type , linear_interp , extrap_type , &
2624 .false. , use_levels_below_ground , use_surface , &
2625 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2626 ids , ide , jds , jde , kds , kde , &
2627 ims , ime , jms , jme , kms , kme , &
2628 its , ite , jts , jte , kts , kte )
2629 else
2630 CALL wrf_error_fatal ('num_qnifa_levels not equal to num_metgrid_levels')
2631 end if
2632 end if
2633 else
2634 CALL wrf_error_fatal ('mp_physics=28 but there is not QNIFA aerosol information from first guess' )
2635 end if do_qnifa
2637 ! Black carbon aerosol
2638 if (config_flags%wif_input_opt .EQ. 2) then
2639 do_qnbca: if (flag_qnbca .EQ. 1) then
2640 if (flag_p_wif .EQ. 1) then
2641 CALL wrf_debug (0 , 'Vertically-interpolating QNBCA first guess from WPS data to fill scalar using native pressure field')
2642 CALL wrf_debug (0 , 'COMMENT: BE SURE num_wif_levels IN NAMELIST EQUALS num_wif_levels IN MET_EM FILES!')
2643 CALL vert_interp ( grid%qnbca_gc , grid%p_wif_gc , scalar(:,:,:,P_QNBCA) , grid%pb , &
2644 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2645 grid%pmaxwnn , grid%ptropnn , &
2646 0 , 0 , &
2647 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2648 config_flags%maxw_above_this_level , &
2649 config_flags%num_wif_levels , 'Q' , &
2650 interp_type , linear_interp , extrap_type , &
2651 .false. , use_levels_below_ground , use_surface , &
2652 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2653 ids , ide , jds , jde , kds , kde , &
2654 ims , ime , jms , jme , kms , kme , &
2655 its , ite , jts , jte , kts , kte )
2656 else ! Interpolate according to metgrid pressure field
2657 if (config_flags%num_wif_levels .EQ. num_metgrid_levels) then ! Check to make sure that the number of aerosol levels is consistent with the metgrid pressure levels
2658 CALL wrf_debug (0 , 'Vertically-interpolating QNBCA first guess from WPS data to fill scalar using metgrid pressure field')
2659 CALL vert_interp ( grid%qnbca_gc , grid%pd_gc , scalar(:,:,:,P_QNBCA) , grid%pb , &
2660 grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , &
2661 grid%pmaxwnn , grid%ptropnn , &
2662 0 , 0 , &
2663 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2664 config_flags%maxw_above_this_level , &
2665 config_flags%num_wif_levels , 'Q' , &
2666 interp_type , linear_interp , extrap_type , &
2667 .false. , use_levels_below_ground , use_surface , &
2668 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2669 ids , ide , jds , jde , kds , kde , &
2670 ims , ime , jms , jme , kms , kme , &
2671 its , ite , jts , jte , kts , kte )
2672 else
2673 CALL wrf_error_fatal ('num_qnifa_levels not equal to num_metgrid_levels')
2674 end if
2675 end if
2676 else
2677 CALL wrf_error_fatal ('mp_physics=28 and wif_input_opt=2 but there is not QNBCA aerosol information from first guess' )
2678 end if do_qnbca
2679 end if
2681 case default
2683 CALL wrf_debug (0 , 'aer_init_opt = ', aer_init_opt)
2684 CALL wrf_error_fatal ('Aerosol forcing option does not exist for mp_physics=28' )
2686 end select select_aer_init_opt_3d
2688 ELSE IF (config_flags%mp_physics .EQ. THOMPSONAERO .and. &
2689 config_flags%wif_input_opt .EQ. 0 ) THEN
2690 CALL wrf_error_fatal ('wif_input_opt=0 but mp_physics=28' )
2691 END IF if_thompsonaero_3d
2693 !=========================================================================================
2694 ! END OF OPTIONAL 3D DATA, USUALLY AEROSOLS
2695 !=========================================================================================
2697 ! If this is UM data, put the dry rho-based pressure back into the dry pressure array.
2698 ! Since the dry pressure is no longer needed, no biggy.
2700 IF ( flag_ptheta .EQ. 1 ) THEN
2701 DO j = jts, MIN(jte,jde-1)
2702 DO k = 1 , num_metgrid_levels
2703 DO i = its, MIN(ite,ide-1)
2704 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2705 grid%pd_gc(i,k,j) = grid%prho_gc(i,k,j)
2706 END DO
2707 END DO
2708 END DO
2709 END IF
2711 #ifdef DM_PARALLEL
2712 ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte
2714 ! For the U and V vertical interpolation, we need the pressure defined
2715 ! at both the locations for the horizontal momentum, which we get by
2716 ! averaging two pressure values (i and i-1 for U, j and j-1 for V). The
2717 ! pressure field on input (grid%pd_gc) and the pressure of the new coordinate
2718 ! (grid%pb) would only need an 8 point stencil. However, the i+1 i-1 and
2719 ! j+1 j-1 for the pressure difference for the max_wind and trop level data
2720 ! require an 8 stencil for all of the mass point variables and a 24-point
2721 ! stencil for U and V.
2723 # include "HALO_EM_VINTERP_UV_1.inc"
2724 #endif
2726 CALL vert_interp ( grid%u_gc , grid%pd_gc , grid%u_2 , grid%pb , &
2727 grid%umaxw , grid%utrop , grid%pmaxw , grid%ptrop , &
2728 grid%pmaxwnn , grid%ptropnn , &
2729 flag_umaxw , flag_utrop , &
2730 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2731 config_flags%maxw_above_this_level , &
2732 num_metgrid_levels , 'U' , &
2733 interp_type , lagrange_order , extrap_type , &
2734 lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
2735 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2736 ids , ide , jds , jde , kds , kde , &
2737 ims , ime , jms , jme , kms , kme , &
2738 its , ite , jts , jte , kts , kte )
2740 CALL vert_interp ( grid%v_gc , grid%pd_gc , grid%v_2 , grid%pb , &
2741 grid%vmaxw , grid%vtrop , grid%pmaxw , grid%ptrop , &
2742 grid%pmaxwnn , grid%ptropnn , &
2743 flag_vmaxw , flag_vtrop , &
2744 config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , &
2745 config_flags%maxw_above_this_level , &
2746 num_metgrid_levels , 'V' , &
2747 interp_type , lagrange_order , extrap_type , &
2748 lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
2749 zap_close_levels , force_sfc_in_vinterp , grid%id , &
2750 ids , ide , jds , jde , kds , kde , &
2751 ims , ime , jms , jme , kms , kme , &
2752 its , ite , jts , jte , kts , kte )
2754 END IF ! <----- END OF VERTICAL INTERPOLATION PART ---->
2756 ! Set the temperature of the inland lakes to tavgsfc if the temperature is available
2757 ! and islake is > num_veg_cat
2759 num_veg_cat = SIZE ( grid%landusef , DIM=2 )
2760 CALL nl_get_iswater ( grid%id , grid%iswater )
2761 CALL nl_get_islake ( grid%id , grid%islake )
2764 IF ( grid%islake < 0 ) THEN
2765 grid%lakeflag=0
2766 CALL wrf_debug ( 0 , 'Old data, no inland lake information')
2768 DO j=jts,MIN(jde-1,jte)
2769 DO i=its,MIN(ide-1,ite)
2770 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2771 IF ( ( ( grid%landusef(i,grid%iswater,j) >= 0.5 ) .OR. ( grid%lu_index(i,j) == grid%iswater ) ) .AND. &
2772 ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) ) THEN
2773 IF ( we_have_tavgsfc ) THEN
2774 grid%sst(i,j) = grid%tavgsfc(i,j)
2775 END IF
2776 IF ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) THEN
2777 grid%sst(i,j) = grid%tsk(i,j)
2778 END IF
2779 IF ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) THEN
2780 grid%sst(i,j) = grid%t2(i,j)
2781 END IF
2782 END IF
2783 END DO
2784 END DO
2785 ELSE
2786 grid%lakeflag=1
2787 IF ( we_have_tavgsfc ) THEN
2789 CALL wrf_debug ( 0 , 'Using inland lakes with average surface temperature')
2790 DO j=jts,MIN(jde-1,jte)
2791 DO i=its,MIN(ide-1,ite)
2792 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2793 IF ( ( grid%landusef(i,grid%islake,j) >= 0.5 ) .OR. ( grid%lu_index(i,j) == grid%islake ) ) THEN
2794 grid%sst(i,j) = grid%tavgsfc(i,j)
2795 grid%tsk(i,j) = grid%tavgsfc(i,j)
2796 END IF
2797 IF ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) THEN
2798 grid%sst(i,j) = grid%t2(i,j)
2799 END IF
2800 END DO
2801 END DO
2803 ELSE ! We don't have tavgsfc
2805 CALL wrf_debug ( 0 , 'No average surface temperature for use with inland lakes')
2807 END IF
2808 DO j=jts,MIN(jde-1,jte)
2809 DO i=its,MIN(ide-1,ite)
2810 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2811 grid%landusef(i,grid%iswater,j) = grid%landusef(i,grid%iswater,j) + &
2812 grid%landusef(i,grid%islake,j)
2813 grid%landusef(i,grid%islake,j) = 0.
2814 END DO
2815 END DO
2816 IF ( config_flags%surface_input_source .EQ. 3 ) THEN
2817 DO j=jts,MIN(jde-1,jte)
2818 DO i=its,MIN(ide-1,ite)
2819 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2820 IF ( grid%lu_index(i,j) .EQ. grid%islake ) THEN
2821 grid%lu_index(i,j) = grid%iswater
2822 END IF
2823 END DO
2824 END DO
2825 END IF
2827 END IF
2829 ! Save the grid%tsk field for later use in the sea ice surface temperature
2830 ! for the Noah LSM scheme.
2832 DO j = jts, MIN(jte,jde-1)
2833 DO i = its, MIN(ite,ide-1)
2834 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2835 grid%tsk_save(i,j) = grid%tsk(i,j)
2836 END DO
2837 END DO
2839 ! Protect against bad grid%tsk values over water by supplying grid%sst (if it is
2840 ! available, and if the grid%sst is reasonable).
2842 DO j = jts, MIN(jde-1,jte)
2843 DO i = its, MIN(ide-1,ite)
2844 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2845 IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. &
2846 ( grid%sst(i,j) .GT. 170. ) .AND. ( grid%sst(i,j) .LT. 400. ) ) THEN
2847 grid%tsk(i,j) = grid%sst(i,j)
2848 ENDIF
2849 END DO
2850 END DO
2852 ! Take the data from the input file and store it in the variables that
2853 ! use the WRF naming and ordering conventions.
2855 DO j = jts, MIN(jte,jde-1)
2856 DO i = its, MIN(ite,ide-1)
2857 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
2858 IF ( grid%snow(i,j) .GE. 10. ) then
2859 grid%snowc(i,j) = 1.
2860 ELSE
2861 grid%snowc(i,j) = 0.0
2862 END IF
2863 END DO
2864 END DO
2866 ! Set flag integers for presence of snowh and soilw fields
2868 grid%ifndsnowh = flag_snowh
2869 IF (num_sw_levels_input .GE. 1) THEN
2870 grid%ifndsoilw = 1
2871 ELSE
2872 grid%ifndsoilw = 0
2873 END IF
2875 ! Set flag integers for presence of albsi, snowsi, and icedepth fields
2877 IF ( config_flags%seaice_albedo_opt == 2 ) THEN
2878 grid%ifndalbsi = flag_albsi
2879 ELSE
2880 grid%ifndalbsi = 0
2881 ENDIF
2883 IF ( config_flags%seaice_snowdepth_opt == 1 ) THEN
2884 grid%ifndsnowsi = flag_snowsi
2885 ELSE
2886 grid%ifndsnowsi = 0
2887 ENDIF
2889 IF ( config_flags%seaice_thickness_opt == 1 ) THEN
2890 grid%ifndicedepth = flag_icedepth
2891 ELSE
2892 grid%ifndicedepth = 0
2893 ENDIF
2895 ! Only certain land surface schemes are able to work with the NLCD data.
2897 CALL nl_get_mminlu ( grid%id , mminlu )
2898 write(a_message,*) 'MMINLU = ',trim(mminlu)
2899 CALL wrf_debug ( 1 , a_message )
2900 write(a_message,*) 'sf_surface_physics = ',model_config_rec%sf_surface_physics(grid%id)
2901 CALL wrf_debug ( 1, a_message )
2903 probs_with_nlcd : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
2905 CASE ( RUCLSMSCHEME, NOAHMPSCHEME, CLMSCHEME, SSIBSCHEME )
2906 IF ( TRIM(mminlu) .EQ. 'NLCD40' ) THEN
2907 CALL wrf_message ( 'NLCD40 data may be used with SLABSCHEME, LSMSCHEME, PXLSMSCHEME' )
2908 CALL wrf_message ( 'Re-run geogrid and choose a different land cover source, or select a different sf_surface_physics option' )
2909 CALL wrf_error_fatal ( 'NLCD40 data may not be used with: RUCLSMSCHEME, NOAHMPSCHEME, CLMSCHEME, SSIBSCHEME' )
2910 END IF
2912 CASE ( SLABSCHEME, LSMSCHEME, PXLSMSCHEME )
2913 CALL wrf_debug ( 1, 'NLCD40 being used with an OK scheme' )
2915 END SELECT probs_with_nlcd
2917 ! We require input data for the various LSM schemes.
2919 enough_data : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
2921 CASE ( LSMSCHEME, NOAHMPSCHEME )
2922 IF ( num_st_levels_input .LT. 2 ) THEN
2923 CALL wrf_error_fatal ( 'Not enough soil temperature data for Noah LSM scheme.')
2924 END IF
2926 CASE (RUCLSMSCHEME)
2927 IF ( num_st_levels_input .LT. 2 ) THEN
2928 CALL wrf_error_fatal ( 'Not enough soil temperature data for RUC LSM scheme.')
2929 END IF
2931 CASE (PXLSMSCHEME)
2932 IF ( num_st_levels_input .LT. 2 ) THEN
2933 CALL wrf_error_fatal ( 'Not enough soil temperature data for P-X LSM scheme.')
2934 END IF
2935 CASE (CLMSCHEME)
2936 IF ( num_st_levels_input .LT. 2 ) THEN
2937 CALL wrf_error_fatal ( 'Not enough soil temperature data for CLM LSM scheme.')
2938 END IF
2939 !---------- fds (06/2010) ---------------------------------
2940 CASE (SSIBSCHEME)
2941 IF ( num_st_levels_input .LT. 2 ) THEN
2942 CALL wrf_error_fatal ( 'Not enough soil temperature data for SSIB LSM scheme.')
2943 END IF
2944 IF ( eta_levels(2) .GT. 0.982 ) THEN
2945 CALL wrf_error_fatal ( 'The first two eta levels are too shallow for SSIB LSM scheme.')
2946 END IF
2947 !--------------------------------------------------------
2949 END SELECT enough_data
2951 interpolate_soil_tmw : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
2953 CASE ( SLABSCHEME,LSMSCHEME,NOAHMPSCHEME,RUCLSMSCHEME,PXLSMSCHEME,CLMSCHEME,SSIBSCHEME )
2954 CALL process_soil_real ( grid%tsk , grid%tmn , grid%tavgsfc, &
2955 grid%landmask , grid%sst , grid%ht, grid%toposoil, &
2956 st_input , sm_input , sw_input , &
2957 st_levels_input , sm_levels_input , sw_levels_input , &
2958 grid%zs , grid%dzs , model_config_rec%flag_sm_adj , &
2959 grid%tslb , grid%smois , grid%sh2o , &
2960 flag_sst , flag_tavgsfc, flag_soilhgt, &
2961 flag_soil_layers, flag_soil_levels, &
2962 ids , ide , jds , jde , kds , kde , &
2963 ims , ime , jms , jme , kms , kme , &
2964 its , ite , jts , jte , kts , kte , &
2965 model_config_rec%sf_surface_physics(grid%id) , &
2966 model_config_rec%num_soil_layers , &
2967 model_config_rec%real_data_init_type , &
2968 num_st_levels_input , num_sm_levels_input , num_sw_levels_input , &
2969 num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc )
2971 END SELECT interpolate_soil_tmw
2973 ! surface_input_source=1 => use data from static file (fractional category as input)
2974 ! surface_input_source=2 => use data from grib file (dominant category as input)
2975 ! surface_input_source=3 => use dominant data from static file (dominant category as input)
2977 IF ( any_valid_points ) THEN
2978 IF ( config_flags%surface_input_source .EQ. 1 ) THEN
2980 ! Generate the vegetation and soil category information from the fractional input
2981 ! data, or use the existing dominant category fields if they exist.
2983 grid%vegcat (its,jts) = 0
2984 grid%soilcat(its,jts) = 0
2986 num_veg_cat = SIZE ( grid%landusef , DIM=2 )
2987 num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 )
2988 num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 )
2990 CALL process_percent_cat_new ( grid%landmask , &
2991 grid%landusef , grid%soilctop , grid%soilcbot , &
2992 grid%isltyp , grid%ivgtyp , &
2993 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
2994 ids , ide , jds , jde , kds , kde , &
2995 ims , ime , jms , jme , kms , kme , &
2996 its , ite , jts , jte , kts , kte , &
2997 model_config_rec%iswater(grid%id) )
2999 ! Make all the veg/soil parms the same so as not to confuse the developer.
3002 DO j = jts , MIN(jde-1,jte)
3003 DO i = its , MIN(ide-1,ite)
3004 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3005 grid%vegcat(i,j) = grid%ivgtyp(i,j)
3006 grid%soilcat(i,j) = grid%isltyp(i,j)
3007 END DO
3008 END DO
3010 ELSE IF ( config_flags%surface_input_source .EQ. 2 ) THEN
3012 ! Do we have dominant soil and veg data from the input already?
3014 IF ( grid%soilcat(i_valid,j_valid) .GT. 0.5 ) THEN
3015 DO j = jts, MIN(jde-1,jte)
3016 DO i = its, MIN(ide-1,ite)
3017 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3018 grid%isltyp(i,j) = NINT( grid%soilcat(i,j) )
3019 END DO
3020 END DO
3021 END IF
3022 IF ( grid%vegcat(i_valid,j_valid) .GT. 0.5 ) THEN
3023 DO j = jts, MIN(jde-1,jte)
3024 DO i = its, MIN(ide-1,ite)
3025 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3026 grid%ivgtyp(i,j) = NINT( grid%vegcat(i,j) )
3027 END DO
3028 END DO
3029 END IF
3031 ELSE IF ( config_flags%surface_input_source .EQ. 3 ) THEN
3033 ! Do we have dominant soil and veg data from the static input already?
3035 IF ( grid%sct_dom_gc(i_valid,j_valid) .GT. 0.5 ) THEN
3036 DO j = jts, MIN(jde-1,jte)
3037 DO i = its, MIN(ide-1,ite)
3038 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3039 grid%isltyp(i,j) = NINT( grid%sct_dom_gc(i,j) )
3040 grid%soilcat(i,j) = grid%isltyp(i,j)
3041 END DO
3042 END DO
3043 ELSE
3044 WRITE ( a_message , * ) 'You have set surface_input_source = 3,'// &
3045 ' but your geogrid data does not have valid dominant soil data.'
3046 CALL wrf_error_fatal ( a_message )
3047 END IF
3048 IF ( grid%lu_index(i_valid,j_valid) .GT. 0.5 ) THEN
3049 DO j = jts, MIN(jde-1,jte)
3050 DO i = its, MIN(ide-1,ite)
3051 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3052 grid%ivgtyp(i,j) = NINT( grid%lu_index(i,j) )
3053 grid%vegcat(i,j) = grid%ivgtyp(i,j)
3054 END DO
3055 END DO
3056 ELSE
3057 WRITE ( a_message , * ) 'You have set surface_input_source = 3,'//&
3058 ' but your geogrid data does not have valid dominant land use data.'
3059 CALL wrf_error_fatal ( a_message )
3060 END IF
3062 ! Need to match isltyp to landmask
3064 iforce = 0
3065 change_soil = 0
3066 change_soilw = 0
3067 DO j = jts, MIN(jde-1,jte)
3068 DO i = its, MIN(ide-1,ite)
3069 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3070 IF ( grid%landmask(i,j) .GT. 0.5 .AND. grid%isltyp(i,j) .EQ. grid%isoilwater ) THEN
3071 grid%isltyp(i,j) = 8
3072 change_soilw = change_soilw + 1
3073 iforce = iforce + 1
3074 ELSE IF ( grid%landmask(i,j) .LT. 0.5 .AND. grid%isltyp(i,j) .NE. grid%isoilwater ) THEN
3075 grid%isltyp(i,j) = grid%isoilwater
3076 change_soil = change_soil + 1
3077 iforce = iforce + 1
3078 END IF
3079 END DO
3080 END DO
3081 IF ( change_soilw .GT. 0 .OR. change_soil .GT. 0 ) THEN
3082 WRITE(a_message,FMT='(A,I4,A,I6)' ) &
3083 'forcing artificial silty clay loam at ',iforce,' points, out of ',&
3084 (MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1)
3085 CALL wrf_debug(0,a_message)
3086 END IF
3088 END IF
3090 ! Split NUDAPT Urban Parameters
3092 IF ( ( config_flags%sf_urban_physics == 1 ) .OR. ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN
3093 DO j = jts , MIN(jde-1,jte)
3094 DO i = its , MIN(ide-1,ite)
3095 IF ( MMINLU == 'NLCD40' .OR. MMINLU == 'MODIFIED_IGBP_MODIS_NOAH') THEN
3096 IF ( grid%FRC_URB2D(i,j) .GE. 0.5 .AND. &
3097 (grid%ivgtyp(i,j).NE.13 .AND. grid%ivgtyp(i,j).NE.24 .AND. grid%ivgtyp(i,j).NE.25 .AND. grid%ivgtyp(i,j).NE.26 .AND. grid%ivgtyp(i,j).LT.30)) grid%ivgtyp(i,j)=13
3098 ELSE IF ( MMINLU == "USGS" ) THEN
3099 IF ( grid%FRC_URB2D(i,j) .GE. 0.5 .AND. &
3100 grid%ivgtyp(i,j).NE.1 ) grid%ivgtyp(i,j)=1
3101 ENDIF
3103 IF ( grid%FRC_URB2D(i,j) == 0. ) THEN
3104 IF ( (MMINLU == 'NLCD40' .OR. MMINLU == 'MODIFIED_IGBP_MODIS_NOAH') .AND. &
3105 (grid%ivgtyp(i,j)==24 .OR. grid%ivgtyp(i,j)==25 .OR. grid%ivgtyp(i,j)==26 .OR. grid%ivgtyp(i,j)==13) ) grid%FRC_URB2D(i,j) = 0.9
3106 IF ( MMINLU == 'USGS' .AND. grid%ivgtyp(i,j)==1 ) grid%FRC_URB2D(i,j) = 0.9
3107 ENDIF
3108 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3109 grid%LP_URB2D(i,j) = grid%URB_PARAM(i,91,j)
3110 grid%LB_URB2D(i,j) = grid%URB_PARAM(i,95,j)
3111 grid%HGT_URB2D(i,j) = grid%URB_PARAM(i,94,j)
3112 END DO
3113 END DO
3114 ENDIF
3116 IF ( ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN
3117 DO j = jts , MIN(jde-1,jte)
3118 DO i = its , MIN(ide-1,ite)
3119 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3120 DO k = 1, 15
3121 grid%HI_URB2D(i,k,j) = grid%URB_PARAM(i,k+117,j)
3122 END DO
3123 END DO
3124 END DO
3125 ENDIF
3127 DO j = jts , MIN(jde-1,jte)
3128 DO i = its , MIN(ide-1,ite)
3129 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3130 IF ( config_flags%sf_urban_physics==1 ) THEN
3131 grid%MH_URB2D(i,j) = grid%URB_PARAM(i,92,j)
3132 grid%STDH_URB2D(i,j) = grid%URB_PARAM(i,93,j)
3133 ENDIF
3134 END DO
3135 END DO
3137 DO j = jts , MIN(jde-1,jte)
3138 DO i = its , MIN(ide-1,ite)
3139 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3140 DO k = 1, 4
3141 IF ( config_flags%sf_urban_physics==1 ) THEN
3142 grid%LF_URB2D(i,k,j) = grid%URB_PARAM(i,k+95,j)
3143 ENDIF
3144 END DO
3145 END DO
3146 END DO
3148 END IF
3150 ! Adjustments for the seaice field PRIOR to the grid%tslb computations. This is
3151 ! is for the 5-layer scheme.
3154 num_veg_cat = SIZE ( grid%landusef , DIM=2 )
3155 num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 )
3156 num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 )
3157 CALL nl_get_seaice_threshold ( grid%id , grid%seaice_threshold )
3158 CALL nl_get_isice ( grid%id , grid%isice )
3159 CALL nl_get_iswater ( grid%id , grid%iswater )
3160 CALL adjust_for_seaice_pre ( grid%xice , grid%landmask , grid%tsk , grid%ivgtyp , grid%vegcat , grid%lu_index , &
3161 grid%xland , grid%landusef , grid%isltyp , grid%soilcat , grid%soilctop , &
3162 grid%soilcbot , grid%tmn , &
3163 grid%seaice_threshold , &
3164 config_flags%fractional_seaice, &
3165 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
3166 grid%iswater , grid%isice , &
3167 model_config_rec%sf_surface_physics(grid%id) , &
3168 ids , ide , jds , jde , kds , kde , &
3169 ims , ime , jms , jme , kms , kme , &
3170 its , ite , jts , jte , kts , kte )
3172 ! Land use assignment.
3174 DO j = jts, MIN(jde-1,jte)
3175 DO i = its, MIN(ide-1,ite)
3176 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3177 grid%lu_index(i,j) = grid%ivgtyp(i,j)
3178 IF ( grid%lu_index(i,j) .NE. model_config_rec%iswater(grid%id) ) THEN
3179 grid%landmask(i,j) = 1
3180 grid%xland(i,j) = 1
3181 ELSE
3182 grid%landmask(i,j) = 0
3183 grid%xland(i,j) = 2
3184 END IF
3185 END DO
3186 END DO
3189 ! Fix grid%tmn and grid%tsk.
3191 fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
3193 CASE ( SLABSCHEME , LSMSCHEME , NOAHMPSCHEME , RUCLSMSCHEME, PXLSMSCHEME,CLMSCHEME, CTSMSCHEME, SSIBSCHEME )
3194 DO j = jts, MIN(jde-1,jte)
3195 DO i = its, MIN(ide-1,ite)
3196 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3197 IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. &
3198 ( grid%sst(i,j) .GT. 170. ) .AND. ( grid%sst(i,j) .LT. 400. ) ) THEN
3199 grid%tmn(i,j) = grid%sst(i,j)
3200 grid%tsk(i,j) = grid%sst(i,j)
3201 ELSE IF ( grid%landmask(i,j) .LT. 0.5 ) THEN
3202 grid%tmn(i,j) = grid%tsk(i,j)
3203 END IF
3204 END DO
3205 END DO
3206 END SELECT fix_tsk_tmn
3208 ! Is the grid%tsk reasonable?
3210 IF ( internal_time_loop .NE. 1 ) THEN
3211 DO j = jts, MIN(jde-1,jte)
3212 DO i = its, MIN(ide-1,ite)
3213 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3214 IF ( grid%tsk(i,j) .LT. 170 .or. grid%tsk(i,j) .GT. 400. ) THEN
3215 grid%tsk(i,j) = grid%t_2(i,1,j)
3216 END IF
3217 END DO
3218 END DO
3219 ELSE
3220 DO j = jts, MIN(jde-1,jte)
3221 DO i = its, MIN(ide-1,ite)
3222 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3223 IF ( grid%tsk(i,j) .LT. 170 .or. grid%tsk(i,j) .GT. 400. ) THEN
3224 print *,'error in the grid%tsk'
3225 print *,'i,j=',i,j
3226 print *,'grid%landmask=',grid%landmask(i,j)
3227 print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j)
3228 if(grid%tmn(i,j).gt.170. .and. grid%tmn(i,j).lt.400.)then
3229 grid%tsk(i,j)=grid%tmn(i,j)
3230 else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then
3231 grid%tsk(i,j)=grid%sst(i,j)
3232 else
3233 CALL wrf_error_fatal ( 'grid%tsk unreasonable' )
3234 end if
3235 END IF
3236 END DO
3237 END DO
3238 END IF
3240 ! Is the grid%tmn reasonable?
3242 DO j = jts, MIN(jde-1,jte)
3243 DO i = its, MIN(ide-1,ite)
3244 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3245 IF ( ( ( grid%tmn(i,j) .LT. 170. ) .OR. ( grid%tmn(i,j) .GT. 400. ) ) &
3246 .AND. ( grid%landmask(i,j) .GT. 0.5 ) ) THEN
3247 IF ( ( model_config_rec%sf_surface_physics(grid%id) .NE. LSMSCHEME ) .and. &
3248 ( model_config_rec%sf_surface_physics(grid%id) .NE. NOAHMPSCHEME ) ) THEN
3249 print *,'error in the grid%tmn'
3250 print *,'i,j=',i,j
3251 print *,'grid%landmask=',grid%landmask(i,j)
3252 print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j)
3253 END IF
3255 if(grid%tsk(i,j).gt.170. .and. grid%tsk(i,j).lt.400.)then
3256 grid%tmn(i,j)=grid%tsk(i,j)
3257 else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then
3258 grid%tmn(i,j)=grid%sst(i,j)
3259 else
3260 CALL wrf_error_fatal ( 'grid%tmn unreasonable' )
3261 endif
3262 END IF
3263 END DO
3264 END DO
3267 ! Minimum soil values, residual, from RUC LSM scheme. For input from Noah or EC, and using
3268 ! RUC LSM scheme, this must be subtracted from the input total soil moisture. For
3269 ! input RUC data and using the Noah LSM scheme, this value must be added to the soil
3270 ! moisture input.
3272 lqmi(1:num_soil_top_cat) = &
3273 (/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, &
3274 0.089, 0.095, 0.10, 0.070, 0.068, 0.078, 0.0, &
3275 0.004, 0.065 /)
3276 ! 0.004, 0.065, 0.020, 0.004, 0.008 /) ! has extra levels for playa, lava, and white sand
3278 ! If Unified Model soil moisture input, add lqmi since UM gives us available soil moisture, not total (AFWA source)
3279 IF ( flag_um_soil == 1 ) THEN
3280 DO j = jts, MIN(jde-1,jte)
3281 DO i = its, MIN(ide-1,ite)
3282 grid%smois(i,:,j)=grid%smois(i,:,j)+lqmi(grid%isltyp(i,j))
3283 END DO
3284 END DO
3285 END IF
3287 ! At the initial time we care about values of soil moisture and temperature, other times are
3288 ! ignored by the model, so we ignore them, too.
3290 IF ( domain_ClockIsStartTime(grid) ) THEN
3291 account_for_zero_soil_moisture : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
3293 CASE ( LSMSCHEME , NOAHMPSCHEME )
3294 iicount = 0
3295 IF ( flag_soil_layers == 1 ) THEN
3296 DO j = jts, MIN(jde-1,jte)
3297 DO i = its, MIN(ide-1,ite)
3298 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3299 IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. &
3300 ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then
3301 print *,'Noah -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j)
3302 iicount = iicount + 1
3304 grid%smois(i,:,j) = 0.005
3305 !+---+-----------------------------------------------------------------+
3306 ! Some bad values of soil moisture are possible (huge negative and positive), but they
3307 ! appear to occur only along coastlines, so instead of overwriting with small moisture
3308 ! values, use relatively large moisture val. Orig code checked for large negative but
3309 ! not positive values, mods here reset either. G. Thompson (28 Feb 2008).
3311 ! grid%smois(i,:,j) = 0.499
3312 ! ELSEIF ( (grid%landmask(i,j).gt.0.5) .and. (grid%tslb(i,1,j) .gt. 170 ) .and. &
3313 ! ( grid%tslb(i,1,j) .lt. 400 ) .and. (grid%smois(i,1,j) .gt. 1.005 ) ) then
3314 ! print *,'Noah -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j)
3315 ! iicount = iicount + 1
3316 ! grid%smois(i,:,j) = 0.499
3317 !+---+-----------------------------------------------------------------+
3318 END IF
3319 END DO
3320 END DO
3321 IF ( iicount .GT. 0 ) THEN
3322 print *,'Noah -> Noah: total number of small soil moisture locations = ',iicount
3323 END IF
3324 ELSE IF ( flag_soil_levels == 1 ) THEN
3325 DO j = jts, MIN(jde-1,jte)
3326 DO i = its, MIN(ide-1,ite)
3327 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3328 grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) , 0.005 )
3329 ! grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) + lqmi(grid%isltyp(i,j)) , 0.005 )
3330 END DO
3331 END DO
3332 DO j = jts, MIN(jde-1,jte)
3333 DO i = its, MIN(ide-1,ite)
3334 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3335 IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. &
3336 ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then
3337 print *,'RUC -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j)
3338 iicount = iicount + 1
3339 grid%smois(i,:,j) = 0.005
3340 !+---+-----------------------------------------------------------------+
3341 ! Same comment as above.
3342 ! grid%smois(i,:,j) = 0.499
3343 ! ELSEIF ( (grid%landmask(i,j).gt.0.5) .and. (grid%tslb(i,1,j) .gt. 170 ) .and. &
3344 ! ( grid%tslb(i,1,j) .lt. 400 ) .and. (grid%smois(i,1,j) .gt. 1.005 ) ) then
3345 ! print *,'Noah -> Noah: bad soil moisture at i,j =',i,j,grid%smois(i,:,j)
3346 ! iicount = iicount + 1
3347 ! grid%smois(i,:,j) = 0.499
3348 !+---+-----------------------------------------------------------------+
3349 END IF
3350 END DO
3351 END DO
3352 IF ( iicount .GT. 0 ) THEN
3353 print *,'RUC -> Noah: total number of small soil moisture locations = ',iicount
3354 END IF
3355 END IF
3357 !+---+-----------------------------------------------------------------+
3358 ! Fudge soil moisture higher where canopy water is non-zero.
3359 ! G. Thompson (12 Jun 2008)
3361 ! DO j = jts, MIN(jte,jde-1)
3362 ! DO i = its, MIN(ite,ide-1)
3363 ! IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3364 ! if (grid%canwat(i,j) .GT. 1.01 .AND. grid%landmask(i,j) .GT. 0.5 ) THEN
3365 ! print *,' CANWAT: moisten soil a bit more at i,j =',i,j,grid%canwat(i,j)
3366 ! grid%smois(i,1,j) = grid%smois(i,1,j) + (grid%canwat(i,j)**0.33333)*0.04
3367 ! grid%smois(i,1,j) = MIN(0.499, grid%smois(i,1,j))
3368 ! grid%smois(i,2,j) = grid%smois(i,2,j) + (grid%canwat(i,j)**0.33333)*0.01
3369 ! grid%smois(i,2,j) = MIN(0.499, grid%smois(i,2,j))
3370 ! end if
3371 ! END DO
3372 ! END DO
3373 !+---+-----------------------------------------------------------------+
3376 CASE ( RUCLSMSCHEME )
3377 iicount = 0
3378 IF ( flag_soil_layers == 1 ) THEN
3379 DO j = jts, MIN(jde-1,jte)
3380 DO i = its, MIN(ide-1,ite)
3381 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3382 grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) , 0.005 )
3383 ! grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) - lqmi(grid%isltyp(i,j)) , 0.005 )
3384 END DO
3385 END DO
3386 ELSE IF ( flag_soil_levels == 1 ) THEN
3387 ! no op
3388 END IF
3390 CASE ( PXLSMSCHEME )
3391 iicount = 0
3392 IF ( flag_soil_layers == 1 ) THEN
3393 ! no op
3394 ELSE IF ( flag_soil_levels == 1 ) THEN
3395 DO j = jts, MIN(jde-1,jte)
3396 DO i = its, MIN(ide-1,ite)
3397 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3398 grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) , 0.005 )
3399 ! grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) + lqmi(grid%isltyp(i,j)) , 0.005 )
3400 END DO
3401 END DO
3402 END IF
3403 CASE ( CLMSCHEME )
3404 iicount = 0
3405 IF ( flag_soil_layers == 1 ) THEN
3406 DO j = jts, MIN(jde-1,jte)
3407 DO i = its, MIN(ide-1,ite)
3408 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3409 IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. &
3410 ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then
3411 print *,'CLM -> CLM: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j)
3412 iicount = iicount + 1
3413 grid%smois(i,:,j) = 0.005
3414 END IF
3415 END DO
3416 END DO
3417 IF ( iicount .GT. 0 ) THEN
3418 print *,'CLM -> CLM: total number of small soil moisture locations = ',iicount
3419 END IF
3420 ELSE IF ( flag_soil_levels == 1 ) THEN
3421 DO j = jts, MIN(jde-1,jte)
3422 DO i = its, MIN(ide-1,ite)
3423 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3424 grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) + lqmi(grid%isltyp(i,j)) , 0.005 )
3425 END DO
3426 END DO
3427 DO j = jts, MIN(jde-1,jte)
3428 DO i = its, MIN(ide-1,ite)
3429 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3430 IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. &
3431 ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then
3432 print *,'CLM -> CLM: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j)
3433 iicount = iicount + 1
3434 grid%smois(i,:,j) = 0.005
3435 END IF
3436 END DO
3437 END DO
3438 IF ( iicount .GT. 0 ) THEN
3439 print *,'CLM -> CLM: total number of small soil moisture locations = ',iicount
3440 END IF
3441 END IF
3443 END SELECT account_for_zero_soil_moisture
3444 END IF
3446 ! Is the grid%tslb reasonable?
3448 IF ( internal_time_loop .NE. 1 ) THEN
3449 DO j = jts, MIN(jde-1,jte)
3450 DO ns = 1 , model_config_rec%num_soil_layers
3451 DO i = its, MIN(ide-1,ite)
3452 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3453 IF ( grid%tslb(i,ns,j) .LT. 170 .or. grid%tslb(i,ns,j) .GT. 400. ) THEN
3454 grid%tslb(i,ns,j) = grid%t_2(i,1,j)
3455 grid%smois(i,ns,j) = 0.3
3456 END IF
3457 END DO
3458 END DO
3459 END DO
3460 ELSE
3461 DO j = jts, MIN(jde-1,jte)
3462 DO i = its, MIN(ide-1,ite)
3463 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3464 IF ( ( ( grid%tslb(i,1,j) .LT. 170. ) .OR. ( grid%tslb(i,1,j) .GT. 400. ) ) .AND. &
3465 ( grid%landmask(i,j) .GT. 0.5 ) ) THEN
3466 IF ( ( model_config_rec%sf_surface_physics(grid%id) .NE. LSMSCHEME ) .AND. &
3467 ( model_config_rec%sf_surface_physics(grid%id) .NE. NOAHMPSCHEME ) .AND. &
3468 ( model_config_rec%sf_surface_physics(grid%id) .NE. RUCLSMSCHEME ).AND. &
3469 ( model_config_rec%sf_surface_physics(grid%id) .NE. SSIBSCHEME ).AND. & !fds
3470 ( model_config_rec%sf_surface_physics(grid%id) .NE. CLMSCHEME ).AND. &
3471 ( model_config_rec%sf_surface_physics(grid%id) .NE. CTSMSCHEME ).AND. &
3472 ( model_config_rec%sf_surface_physics(grid%id) .NE. PXLSMSCHEME ) ) THEN
3473 print *,'error in the grid%tslb'
3474 print *,'i,j=',i,j
3475 print *,'grid%landmask=',grid%landmask(i,j)
3476 print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j)
3477 print *,'grid%tslb = ',grid%tslb(i,:,j)
3478 print *,'old grid%smois = ',grid%smois(i,:,j)
3479 grid%smois(i,1,j) = 0.3
3480 grid%smois(i,2,j) = 0.3
3481 grid%smois(i,3,j) = 0.3
3482 grid%smois(i,4,j) = 0.3
3483 END IF
3485 IF ( (grid%tsk(i,j).GT.170. .AND. grid%tsk(i,j).LT.400.) .AND. &
3486 (grid%tmn(i,j).GT.170. .AND. grid%tmn(i,j).LT.400.) ) THEN
3487 fake_soil_temp : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) )
3488 CASE ( SLABSCHEME )
3489 DO ns = 1 , model_config_rec%num_soil_layers
3490 grid%tslb(i,ns,j) = ( grid%tsk(i,j)*(3.0 - grid%zs(ns)) + &
3491 grid%tmn(i,j)*(0.0 - grid%zs(ns)) ) /(3.0 - 0.0)
3492 END DO
3493 CASE ( LSMSCHEME , NOAHMPSCHEME , RUCLSMSCHEME, PXLSMSCHEME,CLMSCHEME, CTSMSCHEME, SSIBSCHEME )
3494 ! CALL wrf_error_fatal ( 'Assigned constant soil moisture to 0.3, stopping')
3495 DO ns = 1 , model_config_rec%num_soil_layers
3496 grid%tslb(i,ns,j) = ( grid%tsk(i,j)*(3.0 - grid%zs(ns)) + &
3497 grid%tmn(i,j)*(0.0 - grid%zs(ns)) ) /(3.0 - 0.0)
3498 END DO
3499 END SELECT fake_soil_temp
3500 else if(grid%tsk(i,j).gt.170. .and. grid%tsk(i,j).lt.400.)then
3501 CALL wrf_error_fatal ( 'grid%tslb unreasonable 1' )
3502 DO ns = 1 , model_config_rec%num_soil_layers
3503 grid%tslb(i,ns,j)=grid%tsk(i,j)
3504 END DO
3505 else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then
3506 CALL wrf_error_fatal ( 'grid%tslb unreasonable 2' )
3507 DO ns = 1 , model_config_rec%num_soil_layers
3508 grid%tslb(i,ns,j)=grid%sst(i,j)
3509 END DO
3510 else if(grid%tmn(i,j).gt.170. .and. grid%tmn(i,j).lt.400.)then
3511 CALL wrf_error_fatal ( 'grid%tslb unreasonable 3' )
3512 DO ns = 1 , model_config_rec%num_soil_layers
3513 grid%tslb(i,ns,j)=grid%tmn(i,j)
3514 END DO
3515 else
3516 CALL wrf_error_fatal ( 'grid%tslb unreasonable 4' )
3517 endif
3518 END IF
3519 END DO
3520 END DO
3521 END IF
3523 ! Adjustments for the seaice field AFTER the grid%tslb computations. This is
3524 ! is for the Noah LSM scheme.
3526 num_veg_cat = SIZE ( grid%landusef , DIM=2 )
3527 num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 )
3528 num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 )
3529 CALL nl_get_seaice_threshold ( grid%id , grid%seaice_threshold )
3530 CALL nl_get_isice ( grid%id , grid%isice )
3531 CALL nl_get_iswater ( grid%id , grid%iswater )
3532 CALL adjust_for_seaice_post ( grid%xice , grid%landmask , grid%tsk , grid%tsk_save , &
3533 grid%ivgtyp , grid%vegcat , grid%lu_index , &
3534 grid%xland , grid%landusef , grid%isltyp , grid%soilcat , &
3535 grid%soilctop , &
3536 grid%soilcbot , grid%tmn , grid%vegfra , &
3537 grid%tslb , grid%smois , grid%sh2o , &
3538 grid%seaice_threshold , &
3539 grid%sst,flag_sst, &
3540 config_flags%fractional_seaice, &
3541 num_veg_cat , num_soil_top_cat , num_soil_bot_cat , &
3542 model_config_rec%num_soil_layers , &
3543 grid%iswater , grid%isice , &
3544 model_config_rec%sf_surface_physics(grid%id) , &
3545 ids , ide , jds , jde , kds , kde , &
3546 ims , ime , jms , jme , kms , kme , &
3547 its , ite , jts , jte , kts , kte )
3549 ! Let us make sure (again) that the grid%landmask and the veg/soil categories match.
3551 oops1=0
3552 oops2=0
3553 DO j = jts, MIN(jde-1,jte)
3554 DO i = its, MIN(ide-1,ite)
3555 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3556 IF ( ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. &
3557 ( grid%ivgtyp(i,j) .NE. config_flags%iswater .OR. grid%isltyp(i,j) .NE. 14 ) ) .OR. &
3558 ( ( grid%landmask(i,j) .GT. 0.5 ) .AND. &
3559 ( grid%ivgtyp(i,j) .EQ. config_flags%iswater .OR. grid%isltyp(i,j) .EQ. 14 ) ) ) THEN
3560 IF ( grid%tslb(i,1,j) .GT. 1. ) THEN
3561 oops1=oops1+1
3562 grid%ivgtyp(i,j) = 5
3563 grid%isltyp(i,j) = 8
3564 grid%landmask(i,j) = 1
3565 grid%xland(i,j) = 1
3566 ELSE IF ( grid%sst(i,j) .GT. 1. ) THEN
3567 oops2=oops2+1
3568 grid%ivgtyp(i,j) = config_flags%iswater
3569 grid%isltyp(i,j) = 14
3570 grid%landmask(i,j) = 0
3571 grid%xland(i,j) = 2
3572 ELSE
3573 print *,'the grid%landmask and soil/veg cats do not match'
3574 print *,'i,j=',i,j
3575 print *,'grid%landmask=',grid%landmask(i,j)
3576 print *,'grid%ivgtyp=',grid%ivgtyp(i,j)
3577 print *,'grid%isltyp=',grid%isltyp(i,j)
3578 print *,'iswater=', config_flags%iswater
3579 print *,'grid%tslb=',grid%tslb(i,:,j)
3580 print *,'grid%sst=',grid%sst(i,j)
3581 CALL wrf_error_fatal ( 'mismatch_landmask_ivgtyp' )
3582 END IF
3583 END IF
3584 END DO
3585 END DO
3586 if (oops1.gt.0) then
3587 print *,'points artificially set to land : ',oops1
3588 endif
3589 if(oops2.gt.0) then
3590 print *,'points artificially set to water: ',oops2
3591 endif
3592 ! fill grid%sst array with grid%tsk if missing in real input (needed for time-varying grid%sst in wrf)
3593 DO j = jts, MIN(jde-1,jte)
3594 DO i = its, MIN(ide-1,ite)
3595 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3596 IF ( flag_sst .NE. 1 ) THEN
3597 grid%sst(i,j) = grid%tsk(i,j)
3598 ENDIF
3599 END DO
3600 END DO
3601 !tgs set snoalb to land value if the water point is covered with ice
3602 DO j = jts, MIN(jde-1,jte)
3603 DO i = its, MIN(ide-1,ite)
3604 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3605 IF ( grid%ivgtyp(i,j) .EQ. config_flags%isice) THEN
3606 grid%snoalb(i,j) = 0.75
3607 ENDIF
3608 END DO
3609 END DO
3611 ! From the full level data, we can get the half levels, reciprocals, and layer
3612 ! thicknesses. These are all defined at half level locations, so one less level.
3613 ! We allow the vertical coordinate to *accidently* come in upside down. We want
3614 ! the first full level to be the ground surface.
3616 ! Check whether grid%znw (full level) data are truly full levels. If not, we need to adjust them
3617 ! to be full levels.
3618 ! in this test, we check if grid%znw(1) is neither 0 nor 1 (within a tolerance of 10**-5)
3620 were_bad = .false.
3621 IF ( ( (grid%znw(1).LT.(1-1.E-5) ) .OR. ( grid%znw(1).GT.(1+1.E-5) ) ).AND. &
3622 ( (grid%znw(1).LT.(0-1.E-5) ) .OR. ( grid%znw(1).GT.(0+1.E-5) ) ) ) THEN
3623 were_bad = .true.
3624 print *,'Your grid%znw input values are probably half-levels. '
3625 print *,grid%znw
3626 print *,'WRF expects grid%znw values to be full levels. '
3627 print *,'Adjusting now to full levels...'
3628 ! We want to ignore the first value if it's negative
3629 IF (grid%znw(1).LT.0) THEN
3630 grid%znw(1)=0
3631 END IF
3632 DO k=2,kde
3633 grid%znw(k)=2*grid%znw(k)-grid%znw(k-1)
3634 END DO
3635 END IF
3637 ! Let's check our changes
3639 IF ( ( ( grid%znw(1) .LT. (1-1.E-5) ) .OR. ( grid%znw(1) .GT. (1+1.E-5) ) ).AND. &
3640 ( ( grid%znw(1) .LT. (0-1.E-5) ) .OR. ( grid%znw(1) .GT. (0+1.E-5) ) ) ) THEN
3641 print *,'The input grid%znw height values were half-levels or erroneous. '
3642 print *,'Attempts to treat the values as half-levels and change them '
3643 print *,'to valid full levels failed.'
3644 CALL wrf_error_fatal("bad grid%znw values from input files")
3645 ELSE IF ( were_bad ) THEN
3646 print *,'...adjusted. grid%znw array now contains full eta level values. '
3647 ENDIF
3649 IF ( grid%znw(1) .LT. grid%znw(kde) ) THEN
3650 DO k=1, kde/2
3651 hold_znw = grid%znw(k)
3652 grid%znw(k)=grid%znw(kde+1-k)
3653 grid%znw(kde+1-k)=hold_znw
3654 END DO
3655 END IF
3657 DO k=1, kde-1
3658 grid%dnw(k) = grid%znw(k+1) - grid%znw(k)
3659 grid%rdnw(k) = 1./grid%dnw(k)
3660 grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k))
3661 END DO
3663 ! Now the same sort of computations with the half eta levels, even ANOTHER
3664 ! level less than the one above.
3666 DO k=2, kde-1
3667 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1))
3668 grid%rdn(k) = 1./grid%dn(k)
3669 grid%fnp(k) = .5* grid%dnw(k )/grid%dn(k)
3670 grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k)
3671 END DO
3673 ! Scads of vertical coefficients.
3675 cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2)
3676 cof2 = grid%dn(2) /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3)
3678 grid%cf1 = grid%fnp(2) + cof1
3679 grid%cf2 = grid%fnm(2) - cof1 - cof2
3680 grid%cf3 = cof2
3682 grid%cfn = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1)
3683 grid%cfn1 = -.5*grid%dnw(kde-1)/grid%dn(kde-1)
3685 ! Inverse grid distances.
3687 grid%rdx = 1./config_flags%dx
3688 grid%rdy = 1./config_flags%dy
3690 ! Some of the many weird geopotential initializations that we'll see today: grid%ph0 is total,
3691 ! and grid%ph_2 is a perturbation from the base state geopotential. We set the base geopotential
3692 ! at the lowest level to terrain elevation * gravity.
3694 DO j=jts,jte
3695 DO i=its,ite
3696 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3697 grid%ph0(i,1,j) = grid%ht(i,j) * g
3698 grid%ph_2(i,1,j) = 0.
3699 END DO
3700 END DO
3702 ! Base state potential temperature and inverse density (alpha = 1/rho) from
3703 ! the half eta levels and the base-profile surface pressure. Compute 1/rho
3704 ! from equation of state. The potential temperature is a perturbation from t0.
3706 DO j = jts, MIN(jte,jde-1)
3707 DO i = its, MIN(ite,ide-1)
3709 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3711 ! Base state pressure is a function of eta level and terrain, only, plus
3712 ! the hand full of constants: p00 (sea level pressure, Pa), t00 (sea level
3713 ! temperature, K), and A (temperature difference, from 1000 mb to 300 mb, K).
3715 p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 )
3718 DO k = 1, kte-1
3719 grid%php(i,k,j) = grid%c3f(k)*(p_surf - grid%p_top)+grid%c4f(k) + grid%p_top ! temporary, full lev base pressure
3720 grid%pb(i,k,j) = grid%c3h(k)*(p_surf - grid%p_top)+grid%c4h(k) + grid%p_top
3721 temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) )
3722 IF ( grid%pb(i,k,j) .LT. p_strat ) THEN
3723 temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat )
3724 ENDIF
3725 ! temp = t00 + A*LOG(grid%pb(i,k,j)/p00)
3726 grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
3727 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
3728 END DO
3729 grid%php(i,kte,j) = grid%p_top
3730 ! Base state mu is defined as base state surface pressure minus grid%p_top
3731 grid%MUB(i,j) = p_surf - grid%p_top
3732 ! Dry surface pressure is defined as the following (this mu is from the input file
3733 ! computed from the dry pressure). Here the dry pressure is just reconstituted.
3734 pd_surf = grid%MU0(i,j) + grid%p_top
3735 ! Integrate base geopotential, starting at terrain elevation. This assures that
3736 ! the base state is in exact hydrostatic balance with respect to the model equations.
3737 ! This field is on full levels.
3738 grid%phb(i,1,j) = grid%ht(i,j) * g
3739 IF (grid%hypsometric_opt == 1) THEN
3740 DO kk = 2,kte
3741 k = kk-1
3742 grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*(grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))*grid%alb(i,kk-1,j)
3743 END DO
3744 ELSE IF (grid%hypsometric_opt == 2) THEN
3745 DO k = 2,kte
3746 pfu = grid%c3f(k )*grid%MUB(i,j)+grid%c4f(k ) + grid%p_top
3747 pfd = grid%c3f(k-1)*grid%MUB(i,j)+grid%c4f(k-1) + grid%p_top
3748 phm = grid%c3h(k-1)*grid%MUB(i,j)+grid%c4h(k-1) + grid%p_top
3749 grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu)
3750 END DO
3751 ELSE
3752 CALL wrf_error_fatal( 'initialize_real: hypsometric_opt should be 1 or 2' )
3753 END IF
3755 END DO
3756 END DO
3758 !+---+-----------------------------------------------------------------+
3759 ! New addition by Greg Thompson to dry out the stratosphere.
3760 ! CALL wrf_debug ( 0 , ' calling routine to dry stratosphere')
3761 ! CALL dry_stratos ( grid%t_2, moist(:,:,:,P_QV), grid%phb, &
3762 ! ids , ide , jds , jde , kds , kde , &
3763 ! ims , ime , jms , jme , kms , kme , &
3764 ! its , ite , jts , jte , kts , kte )
3765 !+---+-----------------------------------------------------------------+
3767 ! Fill in the outer rows and columns to allow us to be sloppy.
3769 IF ( ite .EQ. ide ) THEN
3770 i = ide
3771 DO j = jts, MIN(jde-1,jte)
3772 grid%MUB(i,j) = grid%MUB(i-1,j)
3773 grid%MU_2(i,j) = grid%MU_2(i-1,j)
3774 DO k = 1, kte-1
3775 grid%pb(i,k,j) = grid%pb(i-1,k,j)
3776 grid%t_init(i,k,j) = grid%t_init(i-1,k,j)
3777 grid%alb(i,k,j) = grid%alb(i-1,k,j)
3778 END DO
3779 DO k = 1, kte
3780 grid%phb(i,k,j) = grid%phb(i-1,k,j)
3781 END DO
3782 END DO
3783 END IF
3785 IF ( jte .EQ. jde ) THEN
3786 j = jde
3787 DO i = its, ite
3788 grid%MUB(i,j) = grid%MUB(i,j-1)
3789 grid%MU_2(i,j) = grid%MU_2(i,j-1)
3790 DO k = 1, kte-1
3791 grid%pb(i,k,j) = grid%pb(i,k,j-1)
3792 grid%t_init(i,k,j) = grid%t_init(i,k,j-1)
3793 grid%alb(i,k,j) = grid%alb(i,k,j-1)
3794 END DO
3795 DO k = 1, kte
3796 grid%phb(i,k,j) = grid%phb(i,k,j-1)
3797 END DO
3798 END DO
3799 END IF
3801 ! Compute the total column perturbation dry pressure (grid%mub + grid%mu_2 + ptop = dry grid%psfc).
3803 DO j = jts, min(jde-1,jte)
3804 DO i = its, min(ide-1,ite)
3805 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3806 grid%MU_2(i,j) = grid%MU0(i,j) - grid%MUB(i,j)
3807 END DO
3808 END DO
3810 ! Fill in the outer rows and columns to allow us to be sloppy.
3812 IF ( ite .EQ. ide ) THEN
3813 i = ide
3814 DO j = jts, MIN(jde-1,jte)
3815 grid%MU_2(i,j) = grid%MU_2(i-1,j)
3816 END DO
3817 END IF
3819 IF ( jte .EQ. jde ) THEN
3820 j = jde
3821 DO i = its, ite
3822 grid%MU_2(i,j) = grid%MU_2(i,j-1)
3823 END DO
3824 END IF
3826 lev500 = 0
3827 DO j = jts, min(jde-1,jte)
3828 DO i = its, min(ide-1,ite)
3829 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
3831 ! Assign the potential temperature (perturbation from t0) and qv on all the mass
3832 ! point locations.
3834 DO k = 1 , kde-1
3835 grid%t_2(i,k,j) = grid%t_2(i,k,j) - t0
3836 END DO
3838 dpmu = 10001.
3839 loop_count = 0
3841 DO WHILE ( ( ABS(dpmu) .GT. 10. ) .AND. &
3842 ( loop_count .LT. 5 ) )
3844 loop_count = loop_count + 1
3846 ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum
3847 ! equation) down from the top to get the pressure perturbation. First get the pressure
3848 ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level.
3850 kk = kte-1
3851 k = kk+1
3853 qtot=0.
3854 DO im = PARAM_FIRST_SCALAR, num_3d_m
3855 qtot = qtot + moist(i,kk,j,im)
3856 ENDDO
3857 qvf2 = 1./(1.+qtot)
3858 qvf1 = qtot*qvf2
3860 grid%p(i,kk,j) = - 0.5*((grid%c1f(k)*grid%Mu_2(i,j))+qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/grid%rdnw(kk)/qvf2
3861 qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
3862 grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf&
3863 *(((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
3864 grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
3865 grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
3867 ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two
3868 ! inverse density fields (total and perturbation).
3870 DO kk=kte-2,1,-1
3871 k = kk + 1
3872 qtot=0.
3873 DO im = PARAM_FIRST_SCALAR, num_3d_m
3874 qtot = qtot + 0.5*(moist(i,kk,j,im)+moist(i,kk+1,j,im))
3875 ENDDO
3876 qvf2 = 1./(1.+qtot)
3877 qvf1 = qtot*qvf2
3878 grid%p(i,kk,j) = grid%p(i,kk+1,j) - ((grid%c1f(k)*grid%Mu_2(i,j)) + qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/qvf2/grid%rdn(kk+1)
3879 qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
3880 grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
3881 (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
3882 grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
3883 grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
3884 END DO
3886 #if 1
3887 ! This is the hydrostatic equation used in the model after the small timesteps. In
3888 ! the model, grid%al (inverse density) is computed from the geopotential.
3890 IF (grid%hypsometric_opt == 1) THEN
3891 DO kk = 2,kte
3892 k = kk - 1
3893 grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - &
3894 grid%dnw(kk-1) * ( ((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*grid%al(i,kk-1,j) &
3895 + (grid%c1h(k)*grid%mu_2(i,j))*grid%alb(i,kk-1,j) )
3896 grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j)
3897 END DO
3898 ELSE IF (grid%hypsometric_opt == 2) THEN
3899 ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure.
3900 ! Note that al*p approximates Rd*T and dLOG(p) does z.
3901 ! Here T varies mostly linear with z, the first-order integration produces better result.
3903 grid%ph_2(i,1,j) = grid%phb(i,1,j)
3904 DO k = 2,kte
3905 pfu = grid%c3f(k )*grid%MU0(i,j)+grid%c4f(k ) + grid%p_top
3906 pfd = grid%c3f(k-1)*grid%MU0(i,j)+grid%c4f(k-1) + grid%p_top
3907 phm = grid%c3h(k-1)*grid%MU0(i,j)+grid%c4h(k-1) + grid%p_top
3908 grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu)
3909 END DO
3911 DO k = 1,kte
3912 grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j)
3913 END DO
3914 END IF
3915 #else
3916 ! Get the perturbation geopotential from the 3d height array from WPS.
3918 DO k = 2,kte
3919 grid%ph_2(i,k,j) = grid%ph0(i,k,j)*g - grid%phb(i,k,j)
3920 END DO
3921 #endif
3923 ! Recompute density, simlar to what the model does.
3925 IF (grid%hypsometric_opt == 1) THEN
3926 DO k=kts,kte-1
3927 grid%al(i,k,j)=-1./((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*(grid%alb(i,k,j)*(grid%c1h(k)*grid%mu_2(i,j)) &
3928 +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)))
3929 ENDDO
3930 ELSE IF (grid%hypsometric_opt == 2) THEN
3931 DO k=kts,kte-1
3932 pfu = grid%c3f(k+1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k+1)+grid%p_top
3933 pfd = grid%c3f(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k )+grid%p_top
3934 phm = grid%c3h(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k )+grid%p_top
3935 qvf=-1./((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*(grid%alb(i,k,j)*(grid%c1h(k)*grid%mu_2(i,j)) &
3936 +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)))
3937 grid%al(i,k,j) = (grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)) &
3938 /phm/LOG(pfd/pfu)-grid%alb(i,k,j)
3939 #if 0
3940 if ( internal_time_loop .EQ. 1 ) THEN
3941 if (i.eq.its .and. j.eq.its)then
3942 if (k.eq.kts)then
3943 print *,' k old al new al alb new alt dz (m) pres up Pres mid Pres down c3 k c3 k+1 c4 k c4 k+1'
3944 print *,' ======================================================================================================================================================================================================================================='
3945 endif
3946 print *,' ',k,qvf,grid%al(i,k,j),grid%alb(i,k,j),grid%al(i,k,j)+grid%alb(i,k,j),(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)),pfu,phm,pfd,grid%c3f(k),grid%c3f(k+1),grid%c4f(k),grid%c4f(k+1)
3947 endif
3948 endif
3949 #endif
3951 ENDDO
3952 END IF
3954 ! Compute pressure similarly to how computed within model.
3956 DO k=kts,kte-1
3957 qvf = 1.+rvovrd*moist(i,k,j,P_QV)
3958 grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ &
3959 (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv &
3960 -grid%pb(i,k,j)
3961 grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
3962 grid%alt(i,k,j) = grid%al(i,k,j) + grid%alb(i,k,j)
3963 ENDDO
3965 ! Adjust the column pressure so that the computed 500 mb height is close to the
3966 ! input value (of course, not when we are doing hybrid input).
3968 IF ( ( flag_metgrid .EQ. 1 ) .AND. ( i .EQ. i_valid ) .AND. ( j .EQ. j_valid ) ) THEN
3969 DO k = 1 , num_metgrid_levels
3970 IF ( ABS ( grid%p_gc(i,k,j) - 50000. ) .LT. 1. ) THEN
3971 lev500 = k
3972 EXIT
3973 END IF
3974 END DO
3975 END IF
3977 ! We only do the adjustment of height if we have the input data on pressure
3978 ! surfaces, and folks have asked to do this option.
3980 IF ( ( flag_metgrid .EQ. 1 ) .AND. &
3981 ( flag_ptheta .EQ. 0 ) .AND. &
3982 ( config_flags%adjust_heights ) .AND. &
3983 ( lev500 .NE. 0 ) ) THEN
3985 DO k = 2 , kte-1
3987 ! Get the pressures on the full eta levels (grid%php is defined above as
3988 ! the full-lev base pressure, an easy array to use for 3d space).
3990 pl = grid%php(i,k ,j) + &
3991 ( grid%p(i,k-1 ,j) * ( grid%znw(k ) - grid%znu(k ) ) + &
3992 grid%p(i,k ,j) * ( grid%znu(k-1 ) - grid%znw(k ) ) ) / &
3993 ( grid%znu(k-1 ) - grid%znu(k ) )
3994 pu = grid%php(i,k+1,j) + &
3995 ( grid%p(i,k-1+1,j) * ( grid%znw(k +1) - grid%znu(k+1) ) + &
3996 grid%p(i,k +1,j) * ( grid%znu(k-1+1) - grid%znw(k+1) ) ) / &
3997 ( grid%znu(k-1+1) - grid%znu(k+1) )
3999 ! If these pressure levels trap 500 mb, use them to interpolate
4000 ! to the 500 mb level of the computed height.
4002 IF ( ( pl .GE. 50000. ) .AND. ( pu .LT. 50000. ) ) THEN
4003 zl = ( grid%ph_2(i,k ,j) + grid%phb(i,k ,j) ) / g
4004 zu = ( grid%ph_2(i,k+1,j) + grid%phb(i,k+1,j) ) / g
4006 z500 = ( zl * ( LOG(50000.) - LOG(pu ) ) + &
4007 zu * ( LOG(pl ) - LOG(50000.) ) ) / &
4008 ( LOG(pl) - LOG(pu) )
4009 ! z500 = ( zl * ( (50000.) - (pu ) ) + &
4010 ! zu * ( (pl ) - (50000.) ) ) / &
4011 ! ( (pl) - (pu) )
4013 ! Compute the difference of the 500 mb heights (computed minus input), and
4014 ! then the change in grid%mu_2. The grid%php is still full-levels, base pressure.
4016 dz500 = z500 - grid%ght_gc(i,lev500,j)
4017 tvsfc = ((grid%t_2(i,1,j)+t0)*((grid%p(i,1,j)+grid%php(i,1,j))/p1000mb)**(r_d/cp)) * &
4018 (1.+0.6*moist(i,1,j,P_QV))
4019 dpmu = ( grid%php(i,1,j) + grid%p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) )
4020 dpmu = dpmu - ( grid%php(i,1,j) + grid%p(i,1,j) )
4021 grid%MU_2(i,j) = grid%MU_2(i,j) - dpmu
4022 EXIT
4023 END IF
4025 END DO
4026 ELSE
4027 dpmu = 0.
4028 END IF
4030 END DO
4032 END DO
4033 END DO
4035 ! Now we have full pressure on eta levels, get final computation of Qv.
4036 ! The use of u_1 (rh) and v_1 (temperature) is temporary.
4038 grid%v_1 = grid%t_2+t0
4040 CALL theta_to_t ( grid%v_1 , grid%p_hyd , p00 , &
4041 ids , ide , jds , jde , kds , kde , &
4042 ims , ime , jms , jme , kms , kme , &
4043 its , ite , jts , jte , kts , kte )
4045 IF ( config_flags%rh2qv_method .eq. 1 ) THEN
4046 CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p_hyd , moist(:,:,:,P_QV) , &
4047 config_flags%rh2qv_wrt_liquid , &
4048 config_flags%qv_max_p_safe , &
4049 config_flags%qv_max_flag , config_flags%qv_max_value , &
4050 config_flags%qv_min_p_safe , &
4051 config_flags%qv_min_flag , config_flags%qv_min_value , &
4052 ids , ide , jds , jde , kds , kde , &
4053 ims , ime , jms , jme , kms , kme , &
4054 its , ite , jts , jte , kts , kte-1 )
4055 ELSE IF ( config_flags%rh2qv_method .eq. 2 ) THEN
4056 CALL rh_to_mxrat2(grid%u_1, grid%v_1, grid%p_hyd , moist(:,:,:,P_QV) , &
4057 config_flags%rh2qv_wrt_liquid , &
4058 config_flags%qv_max_p_safe , &
4059 config_flags%qv_max_flag , config_flags%qv_max_value , &
4060 config_flags%qv_min_p_safe , &
4061 config_flags%qv_min_flag , config_flags%qv_min_value , &
4062 ids , ide , jds , jde , kds , kde , &
4063 ims , ime , jms , jme , kms , kme , &
4064 its , ite , jts , jte , kts , kte-1 )
4065 END IF
4067 ! Compute pressure similarly to how computed within model, with final Qv.
4069 ! Do a re-balance or not? 0 = NOPE
4070 ! Note that rebalance must be 1 for vertical nesting
4071 IF ( config_flags%rebalance .EQ. 0 ) THEN
4073 DO j = jts, min(jde-1,jte)
4074 DO k=kts,kte-1
4075 DO i = its, min(ide,ite)
4076 qvf = 1.+rvovrd*moist(i,k,j,P_QV)
4077 grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ &
4078 (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv &
4079 -grid%pb(i,k,j)
4080 grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
4081 ENDDO
4082 ENDDO
4083 ENDDO
4085 ELSE ! rebalance
4087 lev500 = 0
4088 DO j = jts, min(jde-1,jte)
4089 DO i = its, min(ide-1,ite)
4090 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4092 dpmu = 10001.
4093 loop_count = 0
4095 DO WHILE ( ( ABS(dpmu) .GT. 10. ) .AND. &
4096 ( loop_count .LT. 5 ) )
4098 loop_count = loop_count + 1
4100 ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum
4101 ! equation) down from the top to get the pressure perturbation. First get the pressure
4102 ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level.
4104 kk = kte-1
4105 k=kk+1
4107 qtot=0.
4108 DO im = PARAM_FIRST_SCALAR, num_3d_m
4109 qtot = qtot + moist(i,kk,j,im)
4110 ENDDO
4111 qvf2 = 1./(1.+qtot)
4112 qvf1 = qtot*qvf2
4114 grid%p(i,kk,j) = - 0.5*((grid%c1f(k)*grid%Mu_2(i,j))+qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/grid%rdnw(kk)/qvf2
4115 qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
4116 grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf&
4117 *(((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
4118 grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
4119 grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
4121 ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two
4122 ! inverse density fields (total and perturbation).
4124 DO kk=kte-2,1,-1
4125 k = kk + 1
4126 qtot=0.
4127 DO im = PARAM_FIRST_SCALAR, num_3d_m
4128 qtot = qtot + 0.5*(moist(i,kk,j,im)+moist(i,kk+1,j,im))
4129 ENDDO
4130 qvf2 = 1./(1.+qtot)
4131 qvf1 = qtot*qvf2
4132 grid%p(i,kk,j) = grid%p(i,kk+1,j) - ((grid%c1f(k)*grid%Mu_2(i,j)) + qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/qvf2/grid%rdn(kk+1)
4133 qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
4134 grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
4135 (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
4136 grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
4137 grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
4138 END DO
4140 #if 1
4141 ! This is the hydrostatic equation used in the model after the small timesteps. In
4142 ! the model, grid%al (inverse density) is computed from the geopotential.
4144 IF (grid%hypsometric_opt == 1) THEN
4146 DO kk = 2,kte
4147 k = kk-1
4148 grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - &
4149 grid%dnw(kk-1) * ( ((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*grid%al(i,kk-1,j) &
4150 + (grid%c1h(k)*grid%mu_2(i,j))*grid%alb(i,kk-1,j) )
4151 grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j)
4152 END DO
4154 ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure.
4155 ! Note that al*p approximates Rd*T and dLOG(p) does z.
4156 ! Here T varies mostly linear with z, the first-order integration produces better result.
4158 ELSE IF (grid%hypsometric_opt == 2) THEN
4160 grid%ph_2(i,1,j) = grid%phb(i,1,j)
4161 DO k = 2,kte
4162 pfu = grid%c3f(k )*grid%MU0(i,j)+grid%c4f(k ) + grid%p_top
4163 pfd = grid%c3f(k-1)*grid%MU0(i,j)+grid%c4f(k-1) + grid%p_top
4164 phm = grid%c3h(k-1)*grid%MU0(i,j)+grid%c4h(k-1) + grid%p_top
4165 grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu)
4166 END DO
4168 DO k = 1,kte
4169 grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j)
4170 END DO
4171 END IF
4172 #else
4173 ! Get the perturbation geopotential from the 3d height array from WPS.
4175 DO k = 2,kte
4176 grid%ph_2(i,k,j) = grid%ph0(i,k,j)*g - grid%phb(i,k,j)
4177 END DO
4178 #endif
4180 ! Recompute density, simlar to what the model does.
4182 IF (grid%hypsometric_opt == 1) THEN
4183 DO k=kts,kte-1
4184 grid%al(i,k,j)=-1./((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*(grid%alb(i,k,j)*(grid%c1h(k)*grid%mu_2(i,j)) &
4185 +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)))
4186 ENDDO
4187 ELSE IF (grid%hypsometric_opt == 2) THEN
4188 DO k=kts,kte-1
4189 pfu = grid%c3f(k+1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k+1)+grid%p_top
4190 pfd = grid%c3f(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k )+grid%p_top
4191 phm = grid%c3h(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k )+grid%p_top
4192 grid%al(i,k,j) = (grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)) &
4193 /phm/LOG(pfd/pfu)-grid%alb(i,k,j)
4194 ENDDO
4195 END IF
4197 ! Compute pressure similarly to how computed within model.
4199 DO k=kts,kte-1
4200 qvf = 1.+rvovrd*moist(i,k,j,P_QV)
4201 grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ &
4202 (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv &
4203 -grid%pb(i,k,j)
4204 grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
4205 grid%alt(i,k,j) = grid%al(i,k,j) + grid%alb(i,k,j)
4206 ENDDO
4208 ! Adjust the column pressure so that the computed 500 mb height is close to the
4209 ! input value (of course, not when we are doing hybrid input).
4211 IF ( ( flag_metgrid .EQ. 1 ) .AND. ( i .EQ. i_valid ) .AND. ( j .EQ. j_valid ) ) THEN
4212 DO k = 1 , num_metgrid_levels
4213 IF ( ABS ( grid%p_gc(i,k,j) - 50000. ) .LT. 1. ) THEN
4214 lev500 = k
4215 EXIT
4216 END IF
4217 END DO
4218 END IF
4220 ! We only do the adjustment of height if we have the input data on pressure
4221 ! surfaces, and folks have asked to do this option.
4223 IF ( ( flag_metgrid .EQ. 1 ) .AND. &
4224 ( flag_ptheta .EQ. 0 ) .AND. &
4225 ( config_flags%adjust_heights ) .AND. &
4226 ( lev500 .NE. 0 ) ) THEN
4228 DO k = 2 , kte-1
4230 ! Get the pressures on the full eta levels (grid%php is defined above as
4231 ! the full-lev base pressure, an easy array to use for 3d space).
4233 pl = grid%php(i,k ,j) + &
4234 ( grid%p(i,k-1 ,j) * ( grid%znw(k ) - grid%znu(k ) ) + &
4235 grid%p(i,k ,j) * ( grid%znu(k-1 ) - grid%znw(k ) ) ) / &
4236 ( grid%znu(k-1 ) - grid%znu(k ) )
4237 pu = grid%php(i,k+1,j) + &
4238 ( grid%p(i,k-1+1,j) * ( grid%znw(k +1) - grid%znu(k+1) ) + &
4239 grid%p(i,k +1,j) * ( grid%znu(k-1+1) - grid%znw(k+1) ) ) / &
4240 ( grid%znu(k-1+1) - grid%znu(k+1) )
4242 ! If these pressure levels trap 500 mb, use them to interpolate
4243 ! to the 500 mb level of the computed height.
4245 IF ( ( pl .GE. 50000. ) .AND. ( pu .LT. 50000. ) ) THEN
4246 zl = ( grid%ph_2(i,k ,j) + grid%phb(i,k ,j) ) / g
4247 zu = ( grid%ph_2(i,k+1,j) + grid%phb(i,k+1,j) ) / g
4249 z500 = ( zl * ( LOG(50000.) - LOG(pu ) ) + &
4250 zu * ( LOG(pl ) - LOG(50000.) ) ) / &
4251 ( LOG(pl) - LOG(pu) )
4253 ! Compute the difference of the 500 mb heights (computed minus input), and
4254 ! then the change in grid%mu_2. The grid%php is still full-levels, base pressure.
4256 dz500 = z500 - grid%ght_gc(i,lev500,j)
4257 tvsfc = ((grid%t_2(i,1,j)+t0)*((grid%p(i,1,j)+grid%php(i,1,j))/p1000mb)**(r_d/cp)) * &
4258 (1.+0.6*moist(i,1,j,P_QV))
4259 dpmu = ( grid%php(i,1,j) + grid%p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) )
4260 dpmu = dpmu - ( grid%php(i,1,j) + grid%p(i,1,j) )
4261 grid%MU_2(i,j) = grid%MU_2(i,j) - dpmu
4262 EXIT
4263 END IF
4265 END DO
4266 ELSE
4267 dpmu = 0.
4268 END IF
4270 END DO
4272 ENDDO
4273 ENDDO
4274 END IF ! rebalance
4276 ! If this is data from the SI, then we probably do not have the original
4277 ! surface data laying around. Note that these are all the lowest levels
4278 ! of the respective 3d arrays. For surface pressure, we assume that the
4279 ! vertical gradient of grid%p prime is zilch. This is not all that important.
4280 ! These are filled in so that the various plotting routines have something
4281 ! to play with at the initial time for the model.
4283 IF ( flag_metgrid .NE. 1 ) THEN
4284 DO j = jts, min(jde-1,jte)
4285 DO i = its, min(ide,ite)
4286 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4287 grid%u10(i,j)=grid%u_2(i,1,j)
4288 END DO
4289 END DO
4291 DO j = jts, min(jde,jte)
4292 DO i = its, min(ide-1,ite)
4293 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4294 grid%v10(i,j)=grid%v_2(i,1,j)
4295 END DO
4296 END DO
4298 DO j = jts, min(jde-1,jte)
4299 DO i = its, min(ide-1,ite)
4300 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4301 p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 )
4302 grid%psfc(i,j)=p_surf + grid%p(i,1,j)
4303 grid%q2(i,j)=moist(i,1,j,P_QV)
4304 grid%th2(i,j)=grid%t_2(i,1,j)+300.
4305 grid%t2(i,j)=grid%th2(i,j)*(((grid%p(i,1,j)+grid%pb(i,1,j))/p00)**(r_d/cp))
4306 END DO
4307 END DO
4309 ! If this data is from WPS, then we have previously assigned the surface
4310 ! data for u, v, and t. If we have an input qv, welp, we assigned that one,
4311 ! too. Now we pick up the left overs, and if RH came in - we assign the
4312 ! mixing ratio.
4314 ELSE IF ( flag_metgrid .EQ. 1 ) THEN
4316 DO j = jts, min(jde-1,jte)
4317 DO i = its, min(ide-1,ite)
4318 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4319 ! p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 )
4320 ! grid%psfc(i,j)=p_surf + grid%p(i,1,j)
4321 grid%th2(i,j)=grid%t2(i,j)*(p00/(grid%p(i,1,j)+grid%pb(i,1,j)))**(r_d/cp)
4322 END DO
4323 END DO
4324 IF ( flag_qv .NE. 1 ) THEN
4325 DO j = jts, min(jde-1,jte)
4326 DO i = its, min(ide-1,ite)
4327 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4328 ! grid%q2(i,j)=moist(i,1,j,P_QV)
4329 grid%q2(i,j)=grid%qv_gc(i,1,j)
4330 END DO
4331 END DO
4332 END IF
4334 END IF
4335 CALL cpu_time(t_end)
4337 ! Set flag to denote that we are saving original values of HT, MUB, and
4338 ! PHB for 2-way nesting and cycling.
4340 grid%save_topo_from_real=1
4342 ! Template for initializing tracer arrays.
4343 ! Right now, a small plane in the middle of the domain at lowest model level is
4344 ! defined.
4346 IF (config_flags%tracer_opt .eq. 2) THEN
4347 DO j = (jde + jds)/2 - 4, (jde + jds)/2 + 4, 1
4348 DO i = (ide + ids)/2 - 4, (ide + ids)/2 + 4, 1
4349 IF ( its .LE. i .and. ite .GE. i .and. jts .LE. j .and. jte .GE. j ) THEN
4350 tracer(i, 1, j, P_tr17_1) = 1.
4351 tracer(i, 1, j, P_tr17_2) = 1.
4352 tracer(i, 1, j, P_tr17_3) = 1.
4353 tracer(i, 1, j, P_tr17_4) = 1.
4354 ! tracer(i, 1, j, P_tr17_5) = 1.
4355 ! tracer(i, 1, j, P_tr17_6) = 1.
4356 ! tracer(i, 1, j, P_tr17_7) = 1.
4357 ! tracer(i, 1, j, P_tr17_8) = 1.
4358 END IF
4359 END DO
4360 END DO
4361 END IF
4363 ! Simple initialization for 3d ocean.
4365 IF ( config_flags%sf_ocean_physics .EQ. PWP3DSCHEME ) THEN
4367 ! From a profile of user defined temps, depths, and salinity - we
4368 ! construct a 3d ocean. Because this is a 1d profile, domains that
4369 ! have varied ocean characteristics that deviate should significantly from
4370 ! the provided initial state will probably give poor results.
4372 DO k = 1,model_config_rec%ocean_levels
4373 grid%om_depth(:,k,:) = model_config_rec%ocean_z(k)
4374 grid%om_tmp (:,k,:) = model_config_rec%ocean_t(k)
4375 grid%om_s (:,k,:) = model_config_rec%ocean_s(k)
4376 grid%om_tini (:,k,:) = model_config_rec%ocean_t(k)
4377 grid%om_sini (:,k,:) = model_config_rec%ocean_s(k)
4378 grid%om_u (:,k,:) = 0.
4379 grid%om_v (:,k,:) = 0.
4380 END DO
4382 ! Apparently, the mixed layer is 5 m.
4384 grid%om_ml = 5
4386 ! Keep lat, lon info for the ocean model.
4388 grid%om_lon = grid%xlong
4389 grid%om_lat = grid%xlat
4391 ! If we have access to a non-horizontally isotropic SST, let's
4392 ! use that as a better starting point for the ocean temp. Note that
4393 ! we assume if this is an ice point that implies this is a land point
4394 ! for WRF. If it is a land point, then we do not have any ocean underneath.
4396 IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN
4397 DO j = jts, min(jde-1,jte)
4398 DO k = 1,model_config_rec%ocean_levels
4399 DO i = its, min(ide-1,ite)
4400 grid%om_tmp(i,k,j) = grid%sst(i,j) - ( grid%om_tini(i,1,j) - grid%om_tini(i,k,j) )
4401 END DO
4402 END DO
4403 END DO
4405 DO j = jts, min(jde-1,jte)
4406 DO k = 1,model_config_rec%ocean_levels
4407 DO i = its, min(ide-1,ite)
4408 grid%om_tini(i,k,j) = grid%om_tmp(i,k,j)
4409 END DO
4410 END DO
4411 END DO
4412 END IF
4414 END IF
4416 ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte
4418 !+---+-----------------------------------------------------------------+
4419 !..Scale the lowest level aerosol data into an emissions rate. This is
4420 !.. very far from ideal, but need higher emissions where larger amount
4421 !.. of (climo) existing and lesser emissions where there exists fewer to
4422 !.. begin as a first-order simplistic approach. Later, proper connection to
4423 !.. emission inventory would be better, but, for now, scale like this:
4424 !.. where: Nwfa=50 per cc, emit 0.875E4 aerosols per second per grid box unit
4425 !.. that was tested as ~(20kmx20kmx50m = 2.E10 m**-3)
4426 !..
4427 !..Add option for aerosol emissions from first guess source (e.g., GEOS-5)
4428 !.. Can process aerosol from anthropogenic as well as biomass burning sources
4429 !.. The flag_qn***2d variables in the met_em files must be set to 1
4430 !.. for anthropogenic aerosol emissions to activate
4431 !.. The flag_qn**bba2d variables in the met_em files must be set to 1
4432 !.. to read biomass burning aerosol emissions
4433 !+---+-----------------------------------------------------------------+
4435 if_thompsonaero_2d: IF (config_flags%mp_physics .EQ. THOMPSONAERO .AND. &
4436 config_flags%wif_input_opt .GT. 0) THEN
4438 select_aer_init_opt_2d: select case (aer_init_opt)
4440 case (0) ! Initialize to zero
4442 CALL wrf_debug (0 , 'COMMENT: Surface emissions of QNWFA will be computed in microphysics')
4443 CALL wrf_debug (0 , 'COMMENT: Surface emissions of QNIFA will be initialized to zero values')
4444 do j = jts, MIN(jde-1,jte)
4445 do i = its, MIN(ide-1,ite)
4446 grid%qnwfa2d(i,j) = 0.0
4447 grid%qnifa2d(i,j) = 0.0
4448 enddo
4449 enddo
4451 case (1) ! Monthly climatology (GOCART, etc.)
4453 ! Water-friendly aerosol
4454 CALL wrf_debug (0 , 'Calculating anthropogenic surface emissions of QNWFA using climatology')
4455 do j = jts, min(jde-1,jte)
4456 do i = its, min(ide-1,ite)
4457 z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4458 grid%qnwfa2d(i,j) = grid%w_wif_now(i,1,j) * 0.000196 * (50./z1)
4459 enddo
4460 enddo
4462 ! Ice-friendly aerosol
4463 CALL wrf_debug (0 , 'Setting surface emissions of QNIFA to zero')
4464 do j = jts, min(jde-1,jte)
4465 do i = its, min(ide-1,ite)
4466 grid%qnifa2d(i,j) = 0.0
4467 enddo
4468 enddo
4470 ! Black carbon aerosol
4471 if (config_flags%wif_input_opt .EQ. 2) then
4472 CALL wrf_debug (0 , 'Calculating anthropogenic surface emissions of QNBCA using climatology')
4473 do j = jts, min(jde-1,jte)
4474 do i = its, min(ide-1,ite)
4475 z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4476 grid%qnbca2d(i,j) = grid%b_wif_now(i,1,j) * 0.000098 * (50./z1) * (1. + grid%frc_urb2d(i,j))
4477 enddo
4478 enddo
4479 end if
4481 case (2) ! First guess aerosol (GEOS-5, etc.)
4483 ! Water-friendly aerosol
4484 if (flag_qnwfa2d .EQ. 1) then
4485 CALL wrf_debug (0 , 'Calculating anthropogenic surface emissions of QNWFA using first guess')
4486 do j = jts, min(jde-1,jte)
4487 do i = its, min(ide-1,ite)
4488 z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4489 grid%qnwfa2d(i,j) = grid%qnwfa2d(i,j) * grid%alt(i,1,j) / z1
4490 enddo
4491 enddo
4492 else
4493 CALL wrf_debug (0 , 'Using first guess aerosol option, but no anthropogenic surface emissions of QNWFA found')
4494 CALL wrf_debug (0 , 'Setting anthropogenic surface emissions of QNWFA to zero')
4495 do j = jts, min(jde-1,jte)
4496 do i = its, min(ide-1,ite)
4497 grid%qnwfa2d(i,j) = 0.0
4498 enddo
4499 enddo
4500 end if
4502 ! Ice-friendly aerosol
4503 if (flag_qnifa2d .EQ. 1) then
4504 CALL wrf_debug (0 , 'Calculating surface emissions of QNIFA using first guess')
4505 do j = jts, min(jde-1,jte)
4506 do i = its, min(ide-1,ite)
4507 z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4508 grid%qnifa2d(i,j) = grid%qnifa2d(i,j) * grid%alt(i,1,j) / z1
4509 enddo
4510 enddo
4511 else
4512 CALL wrf_debug (0 , 'Using first guess aerosol option, but no surface emissions of QNIFA found')
4513 CALL wrf_debug (0 , 'Setting surface emissions of QNIFA to zero')
4514 do j = jts, min(jde-1,jte)
4515 do i = its, min(ide-1,ite)
4516 grid%qnifa2d(i,j) = 0.0
4517 enddo
4518 enddo
4519 end if
4521 ! Black carbon aerosol
4522 if (config_flags%wif_input_opt .EQ. 2) then
4523 if (flag_qnbca2d .EQ. 1) then
4524 CALL wrf_debug (0 , 'Calculating surface emissions of QNBCA using first guess')
4525 do j = jts, min(jde-1,jte)
4526 do i = its, min(ide-1,ite)
4527 z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4528 grid%qnbca2d(i,j) = grid%qnbca2d(i,j) * grid%alt(i,1,j) / z1
4529 enddo
4530 enddo
4531 else
4532 CALL wrf_debug (0 , 'Using first guess aerosol option, but no surface emissions of QNBCA found')
4533 CALL wrf_debug (0 , 'Setting surface emissions of QNBCA to zero')
4534 do j = jts, min(jde-1,jte)
4535 do i = its, min(ide-1,ite)
4536 grid%qnbca2d(i,j) = 0.0
4537 enddo
4538 enddo
4539 end if
4540 end if
4542 ! Biomass burning aerosol
4543 if (config_flags%aer_fire_emit_opt .GT. 0) then
4544 ! Organic carbon first
4545 if (flag_qnocbb2d .EQ. 1) then
4546 CALL wrf_debug (0 , 'Calculating biomass burning surface emissions of organic carbon aerosol using first guess')
4547 do j = jts, min(jde-1,jte)
4548 do i = its, min(ide-1,ite)
4549 z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4550 grid%qnocbb2d(i,j) = grid%qnocbb2d(i,j) * grid%alt(i,1,j) / z1
4551 enddo
4552 enddo
4553 else
4554 CALL wrf_debug (0 , 'Using first guess aerosol option, but no biomass burning surface emissions of organic carbon aerosol found')
4555 CALL wrf_debug (0 , 'Setting biomass burning surface emissions of organic carbon aerosol to zero')
4556 do j = jts, min(jde-1,jte)
4557 do i = its, min(ide-1,ite)
4558 grid%qnocbb2d(i,j) = 0.0
4559 enddo
4560 enddo
4561 end if
4563 ! Black carbon second
4564 if (config_flags%aer_fire_emit_opt .EQ. 2) then
4565 if (flag_qnbcbb2d .EQ. 1) then
4566 CALL wrf_debug (0 , 'Calculating biomass burning surface emissions of black carbon aerosol using first guess')
4567 do j = jts, min(jde-1,jte)
4568 do i = its, min(ide-1,ite)
4569 z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g
4570 grid%qnbcbb2d(i,j) = grid%qnbcbb2d(i,j) * grid%alt(i,1,j) / z1
4571 enddo
4572 enddo
4573 else
4574 CALL wrf_debug (0 , 'Using first guess aerosol option, but no biomass burning surface emissions of black carbon aerosol found')
4575 CALL wrf_debug (0 , 'Setting biomass burning surface emissions of black carbon aerosol to zero')
4576 do j = jts, min(jde-1,jte)
4577 do i = its, min(ide-1,ite)
4578 grid%qnbcbb2d(i,j) = 0.0
4579 enddo
4580 enddo
4581 end if
4582 end if
4583 else
4584 CALL wrf_debug (0 , 'Skipping biomass burning surface emissions')
4585 end if
4587 case default
4589 CALL wrf_debug (0 , 'aer_init_opt = ', aer_init_opt)
4590 CALL wrf_error_fatal ('Aerosol forcing option does not exist for mp_physics=28' )
4592 end select select_aer_init_opt_2d
4594 ENDIF if_thompsonaero_2d
4596 !+---+-----------------------------------------------------------------+
4597 !..We can consider that in circumstance of a 'cold start' we can make
4598 !.. an attempt to insert some initial clouds to get a better starting
4599 !.. radiation representation due to clouds using the icloud3 cloud fraction
4600 !.. scheme.
4601 !+---+-----------------------------------------------------------------+
4603 if (config_flags%insert_init_cloud .AND. &
4604 (P_QC .gt. PARAM_FIRST_SCALAR .AND. &
4605 P_QI .gt. PARAM_FIRST_SCALAR)) then
4607 ALLOCATE(temp_P(kts:kte-1))
4608 ALLOCATE(temp_Dz(kts:kte-1))
4609 ALLOCATE(temp_T(kts:kte-1))
4610 ALLOCATE(temp_R(kts:kte-1))
4611 ALLOCATE(temp_Qv(kts:kte-1))
4612 ALLOCATE(temp_Qc(kts:kte-1))
4613 ALLOCATE(temp_Nc(kts:kte-1))
4614 ALLOCATE(temp_Qi(kts:kte-1))
4615 ALLOCATE(temp_Ni(kts:kte-1))
4616 ALLOCATE(temp_Qs(kts:kte-1))
4617 ALLOCATE(temp_CF(kts:kte-1))
4619 i_end = MIN(ite,ide-1)
4620 j_end = MIN(jte,jde-1)
4621 max_relh = 1.5
4622 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
4623 max_relh = wrf_dm_max_real ( MAXVAL(grid%u_1(its:i_end,:,jts:j_end)) )
4624 #else
4625 max_relh = MAXVAL ( grid%u_1(its:i_end,:,jts:j_end) )
4626 #endif
4627 max_relh = max_relh*0.01
4629 gridkm = SQRT(config_flags%dx*config_flags%dy)*0.001
4631 !..As it occurs up above, temporarily utilizing the v_1 variable,
4632 !.. to hold temperature, which it does when time_loop=0.
4634 IF ( internal_time_loop .GT. 1 ) THEN
4635 grid%v_1 = grid%t_2+t0
4636 CALL theta_to_t ( grid%v_1 , grid%p_hyd , p00 , &
4637 ids , ide , jds , jde , kds , kde , &
4638 ims , ime , jms , jme , kms , kme , &
4639 its , ite , jts , jte , kts , kte )
4640 ENDIF
4642 do j = jts, j_end
4643 do i = its, i_end
4644 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4645 debug_flag = .false.
4646 ! if (i.eq.9 .and. j.eq.9) debug_flag = .true.
4648 temp_xland = grid%xland(i,j)
4649 if (grid%lakemask(i,j) .eq. 1) temp_xland = 1
4650 do k = kts, kte-1
4651 temp_Dz(k) = (grid%ph_2(i,k+1,j)+grid%phb(i,k+1,j) - (grid%ph_2(i,k,j)+grid%phb(i,k,j)))/g
4652 temp_P(k) = grid%p_hyd(i,k,j)
4653 temp_T(k) = grid%v_1(i,k,j) ! Around line num 1800 v_1 used to hold temperature.
4654 temp_R(k) = 1./grid%alt(i,k,j)
4655 temp_Qv(k) = moist(i,k,j,P_QV)
4656 temp_Qc(k) = MAX(0., moist(i,k,j,P_QC))
4657 temp_Qi(k) = MAX(0., moist(i,k,j,P_QI))
4658 if (P_QS .gt. 1) then
4659 temp_Qs(k) = MAX(0., moist(i,k,j,P_QS))
4660 else
4661 temp_Qs(k) = 0.
4662 endif
4663 if (P_QNI .gt. 1) then
4664 temp_Ni(k) = MAX(0., scalar(i,k,j,P_QNI))
4665 else
4666 temp_Ni(k) = 0.
4667 endif
4668 if (P_QNC .gt. 1) then
4669 temp_Nc(k) = MAX(0., scalar(i,k,j,P_QNC))
4670 else
4671 temp_Nc(k) = 0.
4672 endif
4673 temp_CF(k) = 0.
4674 enddo
4676 call cal_cldfra3(temp_CF,temp_Qv,temp_Qc,temp_Qi,temp_Qs, &
4677 & temp_Dz, temp_P, temp_T, temp_xland, gridkm, &
4678 & config_flags%insert_init_cloud, max_relh, &
4679 & kts, kte-1, debug_flag)
4681 do k = kts, kte-1
4682 grid%cldfra(i,k,j) = temp_CF(k)
4683 enddo
4685 if (debug_flag) then
4686 do k = kts, kte-1
4687 write(*,*) ' DEBUG_column: ', temp_P(k), temp_T(k), temp_Qv(k), temp_Qc(k), temp_Qi(k), moist(i,k,j,P_QC), moist(i,k,j,P_QI)
4688 enddo
4689 endif
4691 do k = kts, kte-1
4692 moist(i,k,j,P_QV) = MAX(temp_Qv(k), moist(i,k,j,P_QV))
4693 moist(i,k,j,P_QC) = temp_Qc(k)
4694 moist(i,k,j,P_QI) = temp_Qi(k)
4695 enddo
4697 enddo
4698 enddo
4700 DEALLOCATE(temp_P)
4701 DEALLOCATE(temp_Dz)
4702 DEALLOCATE(temp_T)
4703 DEALLOCATE(temp_R)
4704 DEALLOCATE(temp_Qv)
4705 DEALLOCATE(temp_Qc)
4706 DEALLOCATE(temp_Nc)
4707 DEALLOCATE(temp_Qi)
4708 DEALLOCATE(temp_Ni)
4709 DEALLOCATE(temp_Qs)
4710 DEALLOCATE(temp_CF)
4712 endif
4714 !+---+-----------------------------------------------------------------+
4715 !..Let us ensure that double-moment microphysics variables have numbers
4716 !.. where there is mass. Currently doing this for Thompson-MP only, but
4717 !.. can consider doing it for every MP scheme that has 2-moment variables.
4718 !.. This is important because pressure-level RAP/HRRR files have mass but
4719 !.. not number values for example (whereas native model level files have
4720 !.. both).
4721 !+---+-----------------------------------------------------------------+
4723 IF ( config_flags%mp_physics .EQ. THOMPSON .OR. &
4724 config_flags%mp_physics .EQ. THOMPSONAERO ) THEN
4726 !..As it occurs up above, temporarily utilizing the v_1 variable,
4727 !.. to hold temperature, which it does when time_loop=0.
4729 IF ( internal_time_loop .GT. 1 ) THEN
4730 grid%v_1 = grid%t_2+t0
4732 CALL theta_to_t ( grid%v_1 , grid%p_hyd , p00 , &
4733 ids , ide , jds , jde , kds , kde , &
4734 ims , ime , jms , jme , kms , kme , &
4735 its , ite , jts , jte , kts , kte )
4736 ENDIF
4739 do j = jts, MIN(jte,jde-1)
4740 do i = its, MIN(ite,ide-1)
4742 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4744 do k = kts, kte-1
4745 temp_rho = 1./grid%alt(i,k,j)
4747 !..Produce a sensible cloud droplet number concentration
4749 if (P_QNC.gt.1 .AND. moist(i,k,j,P_QC).gt.0.0 .AND. scalar(i,k,j,P_QNC).le.0.0) then
4750 if (P_QNWFA .gt. 1) then
4751 scalar(i,k,j,P_QNC) = make_DropletNumber (moist(i,k,j,P_QC)*temp_rho, &
4752 & scalar(i,k,j,P_QNWFA)*temp_rho, grid%xland(i,j))
4753 else
4754 scalar(i,k,j,P_QNC) = make_DropletNumber (moist(i,k,j,P_QC)*temp_rho, &
4755 & 0.0, grid%xland(i,j))
4756 endif
4757 scalar(i,k,j,P_QNC) = scalar(i,k,j,P_QNC) / temp_rho
4758 endif
4760 !..Produce a sensible cloud ice number concentration
4762 if (P_QNI.gt.1 .AND. moist(i,k,j,P_QI).gt.0.0 .AND. scalar(i,k,j,P_QNI).le.0.0) then
4763 scalar(i,k,j,P_QNI) = make_IceNumber (moist(i,k,j,P_QI)*temp_rho, grid%v_1(i,k,j))
4764 scalar(i,k,j,P_QNI) = scalar(i,k,j,P_QNI) / temp_rho
4765 endif
4767 !..Produce a sensible rain number concentration
4769 if (P_QNR.gt.1 .AND. moist(i,k,j,P_QR).gt.0.0 .AND. scalar(i,k,j,P_QNR).le.0.0) then
4770 scalar(i,k,j,P_QNR) = make_RainNumber (moist(i,k,j,P_QR)*temp_rho, grid%v_1(i,k,j))
4771 scalar(i,k,j,P_QNR) = scalar(i,k,j,P_QNR) / temp_rho
4772 endif
4774 enddo
4776 enddo
4777 enddo
4779 ENDIF
4781 if (config_flags%madwrf_cldinit == 1) &
4782 call Init_madwrf_clouds (moist, p_qv, p_qc, p_qi, p_qs, p00, grid%t_2, grid%p_hyd, grid%ph_2, grid%phb, &
4783 grid%alt, grid%xland, grid%cldmask, grid%cldtopz, grid%cldbasez, grid%brtemp, grid%ht, grid%dx, grid%dy, &
4784 flag_cldmask, flag_cldtopz, flag_cldbasez, flag_brtemp, em_width, hold_ups, ids, ide, jds, jde, its, ims, &
4785 ime, jms, jme, kms, kme, ite, jts, jte, kts, kte, grid%cldfra)
4787 ! MAD-WRF tracers initialization
4788 if (config_flags%madwrf_opt == 2) then
4789 if (f_qc .and. f_qi .and. f_qs) then
4790 call Init_madwrf_tracers (tracer, moist, p_qc, p_qi, p_qs, p_tr_qc, p_tr_qi, p_tr_qs, &
4791 ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte)
4792 else
4793 call wrf_error_fatal('madwrf_opt=2 requires a mp_physics option with qc, qi and qs')
4794 end if
4795 end if
4797 !+---+-----------------------------------------------------------------+
4798 ! Added by Greg Thompson. Pre-set snow depth by latitude, elevation, and day-of-year.
4800 ! CALL wrf_debug ( 0 , ' calling routine to add snow in high mountain peaks')
4801 ! DO j = jts, min(jde-1,jte)
4802 ! DO i = its, min(ide-1,ite)
4803 ! IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4804 ! grid%snowh(i,j) = snowHires (grid%snowh(i,j), grid%xlat(i,j), grid%ht(i,j), current_date, i,j)
4805 ! grid%snow(i,j) = grid%snowh(i,j) * 1000. / 5.
4806 ! END DO
4807 ! END DO
4808 ! CALL wrf_debug ( 0 , ' DONE routine to add snow in high mountain peaks')
4809 !+---+-----------------------------------------------------------------+
4811 ! checking whether var_sso exists in the domain
4812 ! if so, we set got_var_sso flag to true. This is later used in external/RSL_LITE/module_dm.F
4813 ! to check for this, when the topo_wind option is used.
4814 grid%got_var_sso = .FALSE.
4815 DO j=jts,MIN(jde-1,jte)
4816 DO i=its,MIN(ide-1,ite)
4817 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4818 IF(grid%var_sso(i,j) .NE. 0) THEN
4819 grid%got_var_sso = .true.
4820 ENDIF
4821 END DO
4822 END DO
4823 #if ( defined(DM_PARALLEL) && ! defined(STUBMPI) )
4824 grid%got_var_sso = wrf_dm_lor_logical ( grid%got_var_sso )
4825 #endif
4827 ! Save the dry perturbation potential temperature.
4829 DO j = jts, min(jde-1,jte)
4830 DO k = kts, kte
4831 DO i = its, min(ide-1,ite)
4832 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4833 grid%th_phy_m_t0(i,k,j) = grid%t_2(i,k,j)
4834 END DO
4835 END DO
4836 END DO
4838 ! Turn dry potential temperature into moist potential temperature
4839 ! at the very end of this routine, just before the halo communications.
4840 ! This field will be in the model IC and and used to construct the
4841 ! BC file.
4843 IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN
4844 DO j = jts, min(jde-1,jte)
4845 DO k = kts, kte
4846 DO i = its, min(ide,ite)
4847 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
4848 grid%t_2(i,k,j) = ( grid%t_2(i,k,j) + T0 ) * (1. + (R_v/R_d) * moist(i,k,j,P_QV)) - T0
4849 END DO
4850 END DO
4851 END DO
4852 END IF
4854 #ifdef DM_PARALLEL
4855 # include "HALO_EM_INIT_1.inc"
4856 # include "HALO_EM_INIT_2.inc"
4857 # include "HALO_EM_INIT_3.inc"
4858 # include "HALO_EM_INIT_4.inc"
4859 # include "HALO_EM_INIT_5.inc"
4860 IF ( config_flags%sf_ocean_physics .EQ. PWP3DSCHEME ) THEN
4861 # include "HALO_EM_INIT_6.inc"
4862 END IF
4863 #endif
4865 RETURN
4867 END SUBROUTINE init_domain_rk
4869 !---------------------------------------------------------------------
4871 SUBROUTINE const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat )
4872 USE module_configure
4873 IMPLICIT NONE
4874 ! For the real-data-cases only.
4875 REAL , INTENT(OUT) :: p00 , t00 , a , tiso , p_strat , a_strat
4876 CALL nl_get_base_pres ( 1 , p00 )
4877 CALL nl_get_base_temp ( 1 , t00 )
4878 CALL nl_get_base_lapse ( 1 , a )
4879 CALL nl_get_iso_temp ( 1 , tiso )
4880 CALL nl_get_base_pres_strat ( 1 , p_strat )
4881 CALL nl_get_base_lapse_strat ( 1 , a_strat )
4882 END SUBROUTINE const_module_initialize
4884 !-------------------------------------------------------------------
4886 SUBROUTINE rebalance_driver ( grid )
4888 IMPLICIT NONE
4890 TYPE (domain) :: grid
4892 CALL rebalance( grid &
4893 !
4894 #include "actual_new_args.inc"
4895 !
4896 )
4898 END SUBROUTINE rebalance_driver
4900 !---------------------------------------------------------------------
4902 SUBROUTINE rebalance ( grid &
4903 !
4904 #include "dummy_new_args.inc"
4905 !
4906 )
4907 IMPLICIT NONE
4909 TYPE (domain) :: grid
4911 #include "dummy_new_decl.inc"
4913 TYPE (grid_config_rec_type) :: config_flags
4915 REAL :: p_surf , pd_surf, p_surf_int , pb_int , ht_hold
4916 REAL :: qvf , qvf1 , qvf2
4917 REAL :: p00 , t00 , a , tiso , p_strat , a_strat
4918 REAL , DIMENSION(:,:,:) , ALLOCATABLE :: t_init_int
4920 ! Local domain indices and counters.
4922 INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat
4924 INTEGER :: &
4925 ids, ide, jds, jde, kds, kde, &
4926 ims, ime, jms, jme, kms, kme, &
4927 its, ite, jts, jte, kts, kte, &
4928 ips, ipe, jps, jpe, kps, kpe, &
4929 i, j, k, kk
4931 REAL :: temp, temp_int
4932 REAL :: pfu, pfd, phm
4933 REAL :: w1, w2, z0, z1, z2
4935 SELECT CASE ( model_data_order )
4936 CASE ( DATA_ORDER_ZXY )
4937 kds = grid%sd31 ; kde = grid%ed31 ;
4938 ids = grid%sd32 ; ide = grid%ed32 ;
4939 jds = grid%sd33 ; jde = grid%ed33 ;
4941 kms = grid%sm31 ; kme = grid%em31 ;
4942 ims = grid%sm32 ; ime = grid%em32 ;
4943 jms = grid%sm33 ; jme = grid%em33 ;
4945 kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch
4946 its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch
4947 jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch
4949 CASE ( DATA_ORDER_XYZ )
4950 ids = grid%sd31 ; ide = grid%ed31 ;
4951 jds = grid%sd32 ; jde = grid%ed32 ;
4952 kds = grid%sd33 ; kde = grid%ed33 ;
4954 ims = grid%sm31 ; ime = grid%em31 ;
4955 jms = grid%sm32 ; jme = grid%em32 ;
4956 kms = grid%sm33 ; kme = grid%em33 ;
4958 its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch
4959 jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch
4960 kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch
4962 CASE ( DATA_ORDER_XZY )
4963 ids = grid%sd31 ; ide = grid%ed31 ;
4964 kds = grid%sd32 ; kde = grid%ed32 ;
4965 jds = grid%sd33 ; jde = grid%ed33 ;
4967 ims = grid%sm31 ; ime = grid%em31 ;
4968 kms = grid%sm32 ; kme = grid%em32 ;
4969 jms = grid%sm33 ; jme = grid%em33 ;
4971 its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch
4972 kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch
4973 jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch
4975 END SELECT
4977 ALLOCATE ( t_init_int(ims:ime,kms:kme,jms:jme) )
4979 ! Fill config_flags the options for a particular domain
4981 CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
4983 ! Some of the many weird geopotential initializations that we'll see today: grid%ph0 is total,
4984 ! and grid%ph_2 is a perturbation from the base state geopotential. We set the base geopotential
4985 ! at the lowest level to terrain elevation * gravity.
4987 DO j=jts,jte
4988 DO i=its,ite
4989 grid%ph0(i,1,j) = grid%ht_fine(i,j) * g
4990 grid%ph_2(i,1,j) = 0.
4991 END DO
4992 END DO
4994 ! To define the base state, we call a USER MODIFIED routine to set the three
4995 ! necessary constants: p00 (sea level pressure, Pa), t00 (sea level temperature, K),
4996 ! and A (temperature difference, from 1000 mb to 300 mb, K), and constant stratosphere
4997 ! temp (tiso, K) either from input file or from namelist (for backward compatibiliy).
4999 IF ( config_flags%use_baseparam_fr_nml ) then
5000 ! get these from namelist
5001 CALL wrf_message('ndown: using namelist constants')
5002 CALL const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat )
5003 ELSE
5004 ! get these constants from model data
5005 CALL wrf_debug(99,'ndown: using base-state profile constants from input file')
5006 t00 = grid%t00
5007 p00 = grid%p00
5008 a = grid%tlp
5009 tiso = grid%tiso
5010 p_strat = grid%p_strat
5011 a_strat = grid%tlp_strat
5013 IF (t00 .LT. 100. .or. p00 .LT. 10000.) THEN
5014 WRITE(wrf_err_message,*)&
5015 'ndown_em: did not find base state parameters in wrfout. Add use_baseparam_fr_nml = .t. in &dynamics and rerun'
5016 CALL wrf_error_fatal(TRIM(wrf_err_message))
5017 ENDIF
5018 ENDIF
5020 hold_ups = .true.
5022 ! Base state potential temperature and inverse density (alpha = 1/rho) from
5023 ! the half eta levels and the base-profile surface pressure. Compute 1/rho
5024 ! from equation of state. The potential temperature is a perturbation from t0.
5026 DO j = jts, MIN(jte,jde-1)
5027 DO i = its, MIN(ite,ide-1)
5029 ! Base state pressure is a function of eta level and terrain, only, plus
5030 ! the hand full of constants: p00 (sea level pressure, Pa), t00 (sea level
5031 ! temperature, K), and A (temperature difference, from 1000 mb to 300 mb, K).
5032 ! The fine grid terrain is ht_fine, the interpolated is grid%ht.
5034 p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht_fine(i,j)/a/r_d ) **0.5 )
5035 p_surf_int = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j) /a/r_d ) **0.5 )
5037 DO k = 1, kte-1
5038 grid%pb(i,k,j) = grid%c3h(k)*(p_surf - grid%p_top) + grid%c4h(k) + grid%p_top
5039 pb_int = grid%c3h(k)*(p_surf_int - grid%p_top) + grid%c4h(k) + grid%p_top
5040 temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) )
5041 IF ( grid%pb(i,k,j) .LT. p_strat ) THEN
5042 temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat )
5043 ENDIF
5044 ! temp = t00 + A*LOG(pb/p00)
5045 grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
5046 ! grid%t_init(i,k,j) = (t00 + A*LOG(grid%pb(i,k,j)/p00))*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
5047 temp_int = MAX ( tiso, t00 + A*LOG(pb_int /p00) )
5048 IF ( pb_int .LT. p_strat ) THEN
5049 temp_int = tiso + A_strat * LOG ( pb_int/p_strat )
5050 ENDIF
5051 t_init_int(i,k,j)= temp_int*(p00/pb_int )**(r_d/cp) - t0
5052 ! t_init_int(i,k,j)= (t00 + A*LOG(pb_int /p00))*(p00/pb_int )**(r_d/cp) - t0
5053 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
5054 END DO
5055 ! Base state mu is defined as base state surface pressure minus grid%p_top
5056 grid%MUB(i,j) = p_surf - grid%p_top
5057 ! Dry surface pressure is defined as the following (this mu is from the input file
5058 ! computed from the dry pressure). Here the dry pressure is just reconstituted.
5059 pd_surf = ( grid%MUB(i,j) + grid%MU_2(i,j) ) + grid%p_top
5060 ! Integrate base geopotential, starting at terrain elevation. This assures that
5061 ! the base state is in exact hydrostatic balance with respect to the model equations.
5062 ! This field is on full levels.
5063 grid%phb(i,1,j) = grid%ht_fine(i,j) * g
5064 IF (grid%hypsometric_opt == 1) THEN
5065 DO kk = 2,kte
5066 k = kk - 1
5067 grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*(grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))*grid%alb(i,kk-1,j)
5068 END DO
5069 ELSE IF (grid%hypsometric_opt == 2) THEN
5070 DO k = 2,kte
5071 pfu = grid%c3f(k )*grid%MUB(i,j)+grid%c4f(k ) + grid%p_top
5072 pfd = grid%c3f(k-1)*grid%MUB(i,j)+grid%c4f(k-1) + grid%p_top
5073 phm = grid%c3h(k-1)*grid%MUB(i,j)+grid%c4h(k-1) + grid%p_top
5074 grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu)
5075 END DO
5076 ELSE
5077 CALL wrf_error_fatal( 'initialize_real: hypsometric_opt should be 1 or 2' )
5078 END IF
5079 END DO
5080 END DO
5081 ! Replace interpolated terrain with fine grid values.
5082 DO j = jts, MIN(jte,jde-1)
5083 DO i = its, MIN(ite,ide-1)
5084 grid%ht(i,j) = grid%ht_fine(i,j)
5085 END DO
5086 END DO
5087 ! Perturbation fields.
5088 DO j = jts, min(jde-1,jte)
5089 DO i = its, min(ide-1,ite)
5090 ! The potential temperature is THETAnest = THETAinterp + ( TBARnest - TBARinterp)
5091 DO k = 1 , kde-1
5092 grid%t_2(i,k,j) = grid%t_2(i,k,j) + ( grid%t_init(i,k,j) - t_init_int(i,k,j) )
5093 END DO
5094 ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum
5095 ! equation) down from the top to get the pressure perturbation. First get the pressure
5096 ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level.
5097 kk = kte-1
5098 k = kk+1
5099 qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk,j,P_QV))
5100 qvf2 = 1./(1.+qvf1)
5101 qvf1 = qvf1*qvf2
5102 grid%p(i,kk,j) = - 0.5*((grid%c1f(k)*grid%Mu_2(i,j))+qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/grid%rdnw(kk)/qvf2
5103 qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
5104 IF ( config_flags%use_theta_m .EQ. 1 ) THEN
5105 grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)* &
5106 (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
5107 ELSE
5108 grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
5109 (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
5110 END IF
5111 grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
5112 grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
5113 ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two
5114 ! inverse density fields (total and perturbation).
5115 DO kk=kte-2,1,-1
5116 k = kk+1
5117 qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk+1,j,P_QV))
5118 qvf2 = 1./(1.+qvf1)
5119 qvf1 = qvf1*qvf2
5120 grid%p(i,kk,j) = grid%p(i,kk+1,j) - ((grid%c1f(k)*grid%Mu_2(i,j)) + qvf1*(grid%c1f(k)*grid%Mub(i,j)+grid%c2f(k)))/qvf2/grid%rdn(kk+1)
5121 qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
5122 IF ( config_flags%use_theta_m .EQ. 1 ) THEN
5123 grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)* &
5124 (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
5125 ELSE
5126 grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
5127 (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
5128 END IF
5129 grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
5130 grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
5131 END DO
5132 ! This is the hydrostatic equation used in the model after the small timesteps. In
5133 ! the model, grid%al (inverse density) is computed from the geopotential.
5134 IF (grid%hypsometric_opt == 1) THEN
5135 DO kk = 2,kte
5136 k = kk-1
5137 grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - &
5138 grid%dnw(kk-1) * ( ((grid%c1h(k)*grid%mub(i,j)+grid%c2h(k))+(grid%c1h(k)*grid%mu_2(i,j)))*grid%al(i,kk-1,j) &
5139 + (grid%c1h(k)*grid%mu_2(i,j))*grid%alb(i,kk-1,j) )
5140 grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j)
5141 END DO
5142 ELSE IF (grid%hypsometric_opt == 2) THEN
5143 ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure.
5144 ! Note that al*p approximates Rd*T and dLOG(p) does z.
5145 ! Here T varies mostly linear with z, the first-order integration produces better result.
5146 grid%ph_2(i,1,j) = grid%phb(i,1,j)
5147 DO k = 2,kte
5148 pfu = grid%c3f(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k )+grid%p_top
5149 pfd = grid%c3f(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k-1)+grid%p_top
5150 phm = grid%c3h(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k-1)+grid%p_top
5151 grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu)
5152 END DO
5154 DO k = 1,kte
5155 grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j)
5156 END DO
5158 DO k = 1,kte
5159 grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j)
5160 END DO
5162 END IF
5164 ! update psfc in fine grid
5166 z0 = grid%ph0(i,1,j)/g
5167 z1 = 0.5*(grid%ph0(i,1,j)+grid%ph0(i,2,j))/g
5168 z2 = 0.5*(grid%ph0(i,2,j)+grid%ph0(i,3,j))/g
5169 w1 = (z0 - z2)/(z1 - z2)
5170 w2 = 1. - w1
5171 grid%psfc(i,j) = w1*(grid%p(i,1,j)+grid%pb(i,1,j))+w2*(grid%p(i,2,j)+grid%pb(i,2,j))
5173 END DO
5174 END DO
5176 DEALLOCATE ( t_init_int )
5178 ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte
5179 #ifdef DM_PARALLEL
5180 # include "HALO_EM_INIT_1.inc"
5181 # include "HALO_EM_INIT_2.inc"
5182 # include "HALO_EM_INIT_3.inc"
5183 # include "HALO_EM_INIT_4.inc"
5184 # include "HALO_EM_INIT_5.inc"
5185 #endif
5186 END SUBROUTINE rebalance
5188 !---------------------------------------------------------------------
5190 RECURSIVE SUBROUTINE find_my_parent ( grid_ptr_in , grid_ptr_out , id_i_am , id_wanted , found_the_id )
5192 ! RAR - Modified to correct problem in which the parent of a child domain could
5193 ! not be found in the namelist. This condition typically occurs while using the
5194 ! "allow_grid" namelist option when an inactive domain comes before an active
5195 ! domain in the list, i.e., the domain number of the active domain is greater than
5196 ! that of an inactive domain at the same level.
5197 !
5198 USE module_domain
5200 TYPE(domain) , POINTER :: grid_ptr_in , grid_ptr_out
5201 TYPE(domain) , POINTER :: grid_ptr_sibling
5202 INTEGER :: id_wanted , id_i_am
5203 INTEGER :: nest ! RAR
5204 LOGICAL :: found_the_id
5206 found_the_id = .FALSE.
5207 grid_ptr_sibling => grid_ptr_in
5208 nest = 0 ! RAR
5210 DO WHILE ( ASSOCIATED ( grid_ptr_sibling ) )
5212 IF ( grid_ptr_sibling%grid_id .EQ. id_wanted ) THEN
5213 found_the_id = .TRUE.
5214 grid_ptr_out => grid_ptr_sibling
5215 RETURN
5216 ! RAR ELSE IF ( grid_ptr_sibling%num_nests .GT. 0 ) THEN
5217 ELSE IF ( grid_ptr_sibling%num_nests .GT. 0 .AND. nest .LT. grid_ptr_sibling%num_nests ) THEN
5218 nest = nest + 1 ! RAR
5219 grid_ptr_sibling => grid_ptr_sibling%nests(nest)%ptr ! RAR
5220 CALL find_my_parent ( grid_ptr_sibling , grid_ptr_out , id_i_am , id_wanted , found_the_id )
5221 IF (.NOT. found_the_id) grid_ptr_sibling => grid_ptr_sibling%parents(1)%ptr ! RAR
5222 ELSE
5223 grid_ptr_sibling => grid_ptr_sibling%sibling
5224 END IF
5226 END DO
5228 END SUBROUTINE find_my_parent
5230 !---------------------------------------------------------------------
5232 RECURSIVE SUBROUTINE find_my_parent2 ( grid_ptr_in , grid_ptr_out , id_wanted , found_the_id )
5234 USE module_domain
5236 TYPE(domain) , POINTER :: grid_ptr_in
5237 TYPE(domain) , POINTER :: grid_ptr_out
5238 INTEGER , INTENT(IN ) :: id_wanted
5239 LOGICAL , INTENT(OUT) :: found_the_id
5241 ! Local
5243 TYPE(domain) , POINTER :: grid_ptr_holder
5244 INTEGER :: kid
5246 ! Initializations
5248 found_the_id = .FALSE.
5249 grid_ptr_holder => grid_ptr_in
5252 ! Have we found the correct location? If so, we can just pop back up with
5253 ! the pointer to the right location (i.e. the parent), thank you very much.
5255 IF ( id_wanted .EQ. grid_ptr_in%grid_id ) THEN
5257 found_the_id = .TRUE.
5258 grid_ptr_out => grid_ptr_in
5261 ! We gotta keep looking.
5263 ELSE
5265 ! We drill down and process each nest from this domain. We don't have to
5266 ! worry about siblings, as we are running over all of the kids for this parent,
5267 ! so it amounts to the same set of domains being tested.
5269 loop_over_all_kids : DO kid = 1 , grid_ptr_in%num_nests
5271 IF ( ASSOCIATED ( grid_ptr_in%nests(kid)%ptr ) ) THEN
5273 CALL find_my_parent2 ( grid_ptr_in%nests(kid)%ptr , grid_ptr_out , id_wanted , found_the_id )
5274 IF ( found_the_id ) THEN
5275 EXIT loop_over_all_kids
5276 END IF
5278 END IF
5279 END DO loop_over_all_kids
5281 END IF
5283 END SUBROUTINE find_my_parent2
5285 #endif
5287 !---------------------------------------------------------------------
5289 #ifdef VERT_UNIT
5291 !gfortran -DVERT_UNIT -ffree-form -ffree-line-length-none module_initialize_real.F -o vert.exe
5293 !This is a main program for a small unit test for the vertical interpolation.
5295 program vint
5297 implicit none
5299 integer , parameter :: ij = 3
5300 integer , parameter :: keta = 30
5301 integer , parameter :: kgen =20
5303 integer :: ids , ide , jds , jde , kds , kde , &
5304 ims , ime , jms , jme , kms , kme , &
5305 its , ite , jts , jte , kts , kte
5307 integer :: generic
5309 real , dimension(1:ij,kgen,1:ij) :: fo , po
5310 real , dimension(1:ij,1:keta,1:ij) :: fn_calc , fn_interp , pn
5311 real , dimension(1:ij,1:ij) :: not_required_2d_1, not_required_2d_2, &
5312 not_required_2d_3, not_required_2d_4, &
5313 not_required_2d_5, not_required_2d_6
5315 integer, parameter :: interp_type = 1 ! 2
5316 integer, parameter :: extrap_type = 2 ! 1
5317 ! integer, parameter :: lagrange_order = 2 ! 1
5318 integer :: lagrange_order
5319 logical, parameter :: lowest_lev_from_sfc = .FALSE. ! .TRUE.
5320 logical, parameter :: use_levels_below_ground = .TRUE. ! .FALSE. ! .TRUE.
5321 logical, parameter :: use_surface = .TRUE. ! .FALSE. ! .TRUE.
5322 real , parameter :: zap_close_levels = 500. ! 100.
5323 integer, parameter :: force_sfc_in_vinterp = 6 ! 0 ! 6
5324 integer, parameter :: id = 1
5326 integer :: k
5328 ids = 1 ; ide = ij ; jds = 1 ; jde = ij ; kds = 1 ; kde = keta
5329 ims = 1 ; ime = ij ; jms = 1 ; jme = ij ; kms = 1 ; kme = keta
5330 its = 1 ; ite = ij ; jts = 1 ; jte = ij ; kts = 1 ; kte = keta
5332 generic = kgen
5334 print *,' '
5335 print *,'------------------------------------'
5336 print *,'UNIT TEST FOR VERTICAL INTERPOLATION'
5337 print *,'------------------------------------'
5338 print *,' '
5339 do lagrange_order = 1 , 1
5340 print *,' '
5341 print *,'------------------------------------'
5342 print *,'Lagrange Order = ',lagrange_order
5343 print *,'------------------------------------'
5344 print *,' '
5345 call fillitup ( fo , po , fn_calc , pn , &
5346 ids , ide , jds , jde , kds , kde , &
5347 ims , ime , jms , jme , kms , kme , &
5348 its , ite , jts , jte , kts , kte , &
5349 generic , lagrange_order )
5351 print *,' '
5352 print *,'Level Pressure Field'
5353 print *,' (Pa) (generic)'
5354 print *,'------------------------------------'
5355 print *,' '
5356 do k = 1 , generic
5357 write (*,fmt='(i2,2x,f12.3,1x,g15.8)' ) &
5358 k,po(2,k,2),fo(2,k,2)
5359 end do
5360 print *,' '
5362 call vert_interp ( fo , po , fn_interp , pn , &
5363 not_required_2d_1, not_required_2d_2, &
5364 not_required_2d_3, not_required_2d_4, &
5365 not_required_2d_5, not_required_2d_6, &
5366 0 , 0, 5000., 5000., 30000., &
5367 generic , 'T' , &
5368 interp_type , lagrange_order , extrap_type , &
5369 lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
5370 zap_close_levels , force_sfc_in_vinterp , id , &
5371 ids , ide , jds , jde , kds , kde , &
5372 ims , ime , jms , jme , kms , kme , &
5373 its , ite , jts , jte , kts , kte )
5375 print *,'Multi-Order Interpolator'
5376 print *,'------------------------------------'
5377 print *,' '
5378 print *,'Level Pressure Field Field Field'
5379 print *,' (Pa) Calc Interp Diff'
5380 print *,'------------------------------------'
5381 print *,' '
5382 do k = kts , kte-1
5383 write (*,fmt='(i2,2x,f12.3,1x,3(g15.7))' ) &
5384 k,pn(2,k,2),fn_calc(2,k,2),fn_interp(2,k,2),fn_calc(2,k,2)-fn_interp(2,k,2)
5385 end do
5387 end do
5389 end program vint
5391 subroutine wrf_error_fatal (string)
5392 character (len=*) :: string
5393 print *,string
5394 stop
5395 end subroutine wrf_error_fatal
5397 subroutine fillitup ( fo , po , fn , pn , &
5398 ids , ide , jds , jde , kds , kde , &
5399 ims , ime , jms , jme , kms , kme , &
5400 its , ite , jts , jte , kts , kte , &
5401 generic , lagrange_order )
5403 implicit none
5405 integer , intent(in) :: ids , ide , jds , jde , kds , kde , &
5406 ims , ime , jms , jme , kms , kme , &
5407 its , ite , jts , jte , kts , kte
5409 integer , intent(in) :: generic , lagrange_order
5411 real , dimension(ims:ime,generic,jms:jme) , intent(out) :: fo , po
5412 real , dimension(ims:ime,kms:kme,jms:jme) , intent(out) :: fn , pn
5414 integer :: i , j , k
5416 k = 1
5417 do j = jts , jte
5418 do i = its , ite
5419 po(i,k,j) = 102000.
5420 end do
5421 end do
5423 do k = 2 , generic
5424 do j = jts , jte
5425 do i = its , ite
5426 po(i,k,j) = ( 5000. * ( 1 - (k-1) ) + 100000. * ( (k-1) - (generic-1) ) ) / (1. - real(generic-1) )
5427 ! po(i,k,j) = FILL IN YOUR INPUT PRESSURE LEVELS
5428 end do
5429 end do
5430 end do
5432 if ( lagrange_order .eq. 1 ) then
5433 do k = 1 , generic
5434 do j = jts , jte
5435 do i = its , ite
5436 fo(i,k,j) = po(i,k,j)
5437 ! fo(i,k,j) = FILL IN YOUR COLUMN OF PRESS_LEVEL FIELD
5438 end do
5439 end do
5440 end do
5441 else if ( lagrange_order .eq. 2 ) then
5442 do k = 1 , generic
5443 do j = jts , jte
5444 do i = its , ite
5445 fo(i,k,j) = (((po(i,k,j)-5000.)/102000.)*((102000.-po(i,k,j))/102000.))*102000.
5446 end do
5447 end do
5448 end do
5449 end if
5451 !!!!!!!!!!!!
5453 do k = kts , kte
5454 do j = jts , jte
5455 do i = its , ite
5456 pn(i,k,j) = ( 5000. * ( 0 - (k-1) ) + 102000. * ( (k-1) - (kte-1) ) ) / (-1. * real(kte-1) )
5457 ! pn(i,k,j) = FILL IN A COLUMN OF KNOWN FULL-LEVEL PRESSURES ON ETA SURFACES
5458 end do
5459 end do
5460 end do
5462 do k = kts , kte-1
5463 do j = jts , jte
5464 do i = its , ite
5465 pn(i,k,j) = ( pn(i,k,j) + pn(i,k+1,j) ) /2.
5466 end do
5467 end do
5468 end do
5471 if ( lagrange_order .eq. 1 ) then
5472 do k = kts , kte-1
5473 do j = jts , jte
5474 do i = its , ite
5475 fn(i,k,j) = pn(i,k,j)
5476 ! fn(i,k,j) = FILL IN COLUMN OF HALF LEVEL FIELD
5477 end do
5478 end do
5479 end do
5480 else if ( lagrange_order .eq. 2 ) then
5481 do k = kts , kte-1
5482 do j = jts , jte
5483 do i = its , ite
5484 fn(i,k,j) = (((pn(i,k,j)-5000.)/102000.)*((102000.-pn(i,k,j))/102000.))*102000.
5485 ! fn(i,k,j) = sin(pn(i,k,j) * piov2 / 102000. )
5486 end do
5487 end do
5488 end do
5489 end if
5491 end subroutine fillitup
5493 function skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups )
5494 logical :: skip_middle_points_t
5495 integer :: ids , ide , jds , jde , i , j , em_width
5496 logical :: hold_ups
5497 skip_middle_points_t = .false.
5498 end function skip_middle_points_t
5500 subroutine wrf_message(level,message)
5501 character(len=*), intent(in) :: message
5502 integer, intent(in) :: level
5503 print *,trim(message)
5504 end subroutine wrf_message
5506 #endif
5508 !---------------------------------------------------------------------
5510 SUBROUTINE vert_interp ( fo , po , fnew , pnu , &
5511 fo_maxw , fo_trop , po_maxw , po_trop , &
5512 po_maxwnn , po_tropnn , &
5513 flag_maxw , flag_trop , &
5514 maxw_horiz_pres_diff , trop_horiz_pres_diff , &
5515 maxw_above_this_level , &
5516 generic , var_type , &
5517 interp_type , lagrange_order , extrap_type , &
5518 lowest_lev_from_sfc , use_levels_below_ground , use_surface , &
5519 zap_close_levels , force_sfc_in_vinterp , id , &
5520 ids , ide , jds , jde , kds , kde , &
5521 ims , ime , jms , jme , kms , kme , &
5522 its , ite , jts , jte , kts , kte )
5524 ! Vertically interpolate the new field. The original field on the original
5525 ! pressure levels is provided, and the new pressure surfaces to interpolate to.
5527 IMPLICIT NONE
5529 INTEGER , INTENT(IN) :: interp_type , lagrange_order , extrap_type
5530 LOGICAL , INTENT(IN) :: lowest_lev_from_sfc , use_levels_below_ground , use_surface
5531 REAL , INTENT(IN) :: zap_close_levels
5532 REAL , INTENT(IN) :: maxw_horiz_pres_diff , trop_horiz_pres_diff , maxw_above_this_level
5533 INTEGER , INTENT(IN) :: force_sfc_in_vinterp , id
5534 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
5535 ims , ime , jms , jme , kms , kme , &
5536 its , ite , jts , jte , kts , kte
5537 INTEGER , INTENT(IN) :: generic
5538 INTEGER , INTENT(IN) :: flag_maxw , flag_trop
5540 CHARACTER (LEN=1) :: var_type
5542 REAL , DIMENSION(ims:ime,generic,jms:jme) , INTENT(IN) :: fo , po
5543 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: fo_maxw , fo_trop , po_maxw , po_trop
5544 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: po_maxwnn , po_tropnn
5545 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: pnu
5546 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: fnew
5548 REAL , DIMENSION(ims:ime,generic,jms:jme) :: forig , porig
5549 REAL , DIMENSION(ims:ime,jms:jme) :: forig_maxw , forig_trop , porig_maxw , porig_trop
5550 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: pnew
5552 ! Local vars
5554 CHARACTER (LEN=256) :: message
5555 INTEGER :: i , j , k , ko , kn , k1 , k2 , ko_1 , ko_2 , knext
5556 INTEGER :: istart , iend , jstart , jend , kstart , kend
5557 INTEGER , DIMENSION(ims:ime,kms:kme ) :: k_above , k_below
5558 INTEGER , DIMENSION(ims:ime ) :: ks
5559 INTEGER , DIMENSION(ims:ime ) :: ko_above_sfc
5560 INTEGER :: count , zap , zap_below , zap_above , kst , kcount
5561 INTEGER :: kinterp_start , kinterp_end , sfc_level
5563 LOGICAL :: any_below_ground
5565 REAL :: p1 , p2 , pn, hold , zap_close_extra_levels
5566 REAL , DIMENSION(1:generic+flag_maxw+flag_trop) :: ordered_porig , ordered_forig
5567 REAL , DIMENSION(kts:kte) :: ordered_pnew , ordered_fnew
5569 ! Excluded middle.
5571 LOGICAL :: any_valid_points
5572 INTEGER :: i_valid , j_valid
5573 LOGICAL :: flip_data_required
5574 #ifdef VERT_UNIT
5575 LOGICAL, EXTERNAL :: skip_middle_points_t
5576 INTEGER :: em_width
5577 LOGICAL :: hold_ups
5578 #endif
5579 INTEGER :: final_zap_check_count , count_close_by_at_ko
5581 ! Vertical interpolation of the extra levels from metgrid: max wind and tropopause
5583 LOGICAL :: ok_data
5584 INTEGER :: ii, jj
5586 zap_close_extra_levels = 500
5588 ! Horiontal loop bounds for different variable types.
5590 IF ( var_type .EQ. 'U' ) THEN
5591 istart = its
5592 iend = ite
5593 jstart = MAX(jds ,jts-1)
5594 jend = MIN(jde-1,jte+1)
5595 kstart = kts
5596 kend = kte-1
5597 DO j = jstart,jend
5598 DO k = 1,generic
5599 DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1)
5600 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5601 porig(i,k,j) = ( po(i,k,j) + po(i-1,k,j) ) * 0.5
5602 END DO
5603 END DO
5604 DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1)
5605 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5606 porig_maxw(i,j) = ( po_maxw(i,j) + po_maxw(i-1,j) ) * 0.5
5607 porig_trop(i,j) = ( po_trop(i,j) + po_trop(i-1,j) ) * 0.5
5608 END DO
5609 IF ( ids .EQ. its ) THEN
5610 DO k = 1,generic
5611 porig(its,k,j) = po(its,k,j)
5612 END DO
5613 porig_maxw(its,j) = po_maxw(its,j)
5614 porig_trop(its,j) = po_trop(its,j)
5615 END IF
5616 IF ( ide .EQ. ite ) THEN
5617 DO k = 1,generic
5618 porig(ite,k,j) = po(ite-1,k,j)
5619 END DO
5620 porig_maxw(ite,j) = po_maxw(ite-1,j)
5621 porig_trop(ite,j) = po_trop(ite-1,j)
5622 END IF
5624 DO k = kstart,kend
5625 DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1)
5626 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5627 pnew(i,k,j) = ( pnu(i,k,j) + pnu(i-1,k,j) ) * 0.5
5628 END DO
5629 END DO
5630 IF ( ids .EQ. its ) THEN
5631 DO k = kstart,kend
5632 pnew(its,k,j) = pnu(its,k,j)
5633 END DO
5634 END IF
5635 IF ( ide .EQ. ite ) THEN
5636 DO k = kstart,kend
5637 pnew(ite,k,j) = pnu(ite-1,k,j)
5638 END DO
5639 END IF
5640 END DO
5641 ELSE IF ( var_type .EQ. 'V' ) THEN
5642 istart = MAX(ids ,its-1)
5643 iend = MIN(ide-1,ite+1)
5644 jstart = jts
5645 jend = jte
5646 kstart = kts
5647 kend = kte-1
5648 DO i = istart,iend
5649 DO k = 1,generic
5650 DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1)
5651 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5652 porig(i,k,j) = ( po(i,k,j) + po(i,k,j-1) ) * 0.5
5653 END DO
5654 END DO
5655 DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1)
5656 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5657 porig_maxw(i,j) = ( po_maxw(i,j) + po_maxw(i,j-1) ) * 0.5
5658 porig_trop(i,j) = ( po_trop(i,j) + po_trop(i,j-1) ) * 0.5
5659 END DO
5660 IF ( jds .EQ. jts ) THEN
5661 DO k = 1,generic
5662 porig(i,k,jts) = po(i,k,jts)
5663 END DO
5664 porig_maxw(i,jts) = po_maxw(i,jts)
5665 porig_trop(i,jts) = po_trop(i,jts)
5666 END IF
5667 IF ( jde .EQ. jte ) THEN
5668 DO k = 1,generic
5669 porig(i,k,jte) = po(i,k,jte-1)
5670 END DO
5671 porig_maxw(i,jte) = po_maxw(i,jte-1)
5672 porig_trop(i,jte) = po_trop(i,jte-1)
5673 END IF
5675 DO k = kstart,kend
5676 DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1)
5677 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5678 pnew(i,k,j) = ( pnu(i,k,j) + pnu(i,k,j-1) ) * 0.5
5679 END DO
5680 END DO
5681 IF ( jds .EQ. jts ) THEN
5682 DO k = kstart,kend
5683 pnew(i,k,jts) = pnu(i,k,jts)
5684 END DO
5685 END IF
5686 IF ( jde .EQ. jte ) THEN
5687 DO k = kstart,kend
5688 pnew(i,k,jte) = pnu(i,k,jte-1)
5689 END DO
5690 END IF
5691 END DO
5692 ELSE IF ( ( var_type .EQ. 'W' ) .OR. ( var_type .EQ. 'Z' ) ) THEN
5693 istart = its
5694 iend = MIN(ide-1,ite)
5695 jstart = jts
5696 jend = MIN(jde-1,jte)
5697 kstart = kts
5698 kend = kte
5699 DO j = jstart,jend
5700 DO k = 1,generic
5701 DO i = istart,iend
5702 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5703 porig(i,k,j) = po(i,k,j)
5704 END DO
5705 END DO
5706 DO i = istart,iend
5707 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5708 porig_maxw(i,j) = po_maxw(i,j)
5709 porig_trop(i,j) = po_trop(i,j)
5710 END DO
5712 DO k = kstart,kend
5713 DO i = istart,iend
5714 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5715 pnew(i,k,j) = pnu(i,k,j)
5716 END DO
5717 END DO
5718 END DO
5719 ELSE IF ( ( var_type .EQ. 'T' ) .OR. ( var_type .EQ. 'Q' ) ) THEN
5720 istart = its
5721 iend = MIN(ide-1,ite)
5722 jstart = jts
5723 jend = MIN(jde-1,jte)
5724 kstart = kts
5725 kend = kte-1
5726 DO j = jstart,jend
5727 DO k = 1,generic
5728 DO i = istart,iend
5729 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5730 porig(i,k,j) = po(i,k,j)
5731 END DO
5732 END DO
5733 DO i = istart,iend
5734 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5735 porig_maxw(i,j) = po_maxw(i,j)
5736 porig_trop(i,j) = po_trop(i,j)
5737 END DO
5739 DO k = kstart,kend
5740 DO i = istart,iend
5741 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5742 pnew(i,k,j) = pnu(i,k,j)
5743 END DO
5744 END DO
5745 END DO
5746 ELSE
5747 istart = its
5748 iend = MIN(ide-1,ite)
5749 jstart = jts
5750 jend = MIN(jde-1,jte)
5751 kstart = kts
5752 kend = kte-1
5753 DO j = jstart,jend
5754 DO k = 1,generic
5755 DO i = istart,iend
5756 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5757 porig(i,k,j) = po(i,k,j)
5758 END DO
5759 END DO
5761 DO k = kstart,kend
5762 DO i = istart,iend
5763 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5764 pnew(i,k,j) = pnu(i,k,j)
5765 END DO
5766 END DO
5767 END DO
5768 END IF
5770 ! We need to find if there are any valid non-excluded-middle points in this
5771 ! tile. If so, then we need to hang on to a valid i,j location.
5773 any_valid_points = .false.
5774 find_valid : DO j = jstart , jend
5775 DO i = istart , iend
5776 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5777 any_valid_points = .true.
5778 i_valid = i
5779 j_valid = j
5780 EXIT find_valid
5781 END DO
5782 END DO find_valid
5783 IF ( .NOT. any_valid_points ) THEN
5784 RETURN
5785 END IF
5787 IF ( porig(i_valid,2,j_valid) .LT. porig(i_valid,generic,j_valid) ) THEN
5788 flip_data_required = .true.
5789 ELSE
5790 flip_data_required = .false.
5791 END IF
5793 DO j = jstart , jend
5795 ! The lowest level is the surface. Levels 2 through "generic" are supposed to
5796 ! be "bottom-up". Flip if they are not. This is based on the input pressure
5797 ! array.
5799 IF ( flip_data_required ) THEN
5800 DO kn = 2 , ( generic + 1 ) / 2
5801 DO i = istart , iend
5802 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5803 hold = porig(i,kn,j)
5804 porig(i,kn,j) = porig(i,generic+2-kn,j)
5805 porig(i,generic+2-kn,j) = hold
5806 forig(i,kn,j) = fo (i,generic+2-kn,j)
5807 forig(i,generic+2-kn,j) = fo (i,kn,j)
5808 END DO
5809 END DO
5810 DO i = istart , iend
5811 forig(i,1,j) = fo (i,1,j)
5812 END DO
5813 IF ( MOD(generic,2) .EQ. 0 ) THEN
5814 k=generic/2 + 1
5815 DO i = istart , iend
5816 forig(i,k,j) = fo (i,k,j)
5817 END DO
5818 END IF
5819 ELSE
5820 DO kn = 1 , generic
5821 DO i = istart , iend
5822 forig(i,kn,j) = fo (i,kn,j)
5823 END DO
5824 END DO
5825 END IF
5827 ! Skip all of the levels below ground in the original data based upon the surface pressure.
5828 ! The ko_above_sfc is the index in the pressure array that is above the surface. If there
5829 ! are no levels underground, this is index = 2. The remaining levels are eligible for use
5830 ! in the vertical interpolation.
5832 DO i = istart , iend
5833 ko_above_sfc(i) = -1
5834 END DO
5835 DO ko = kstart+1 , generic
5836 DO i = istart , iend
5837 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5838 IF ( ko_above_sfc(i) .EQ. -1 ) THEN
5839 IF ( porig(i,1,j) .GT. porig(i,ko,j) ) THEN
5840 ko_above_sfc(i) = ko
5841 END IF
5842 END IF
5843 END DO
5844 END DO
5846 ! Piece together columns of the original input data. Pass the vertical columns to
5847 ! the iterpolator.
5849 DO i = istart , iend
5850 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
5852 ! If the surface value is in the middle of the array, three steps: 1) do the
5853 ! values below the ground (this is just to catch the occasional value that is
5854 ! inconsistently below the surface based on input data), 2) do the surface level, then
5855 ! 3) add in the levels that are above the surface. For the levels next to the surface,
5856 ! we check to remove any levels that are "too close". When building the column of input
5857 ! pressures, we also attend to the request for forcing the surface analysis to be used
5858 ! in a few lower eta-levels.
5860 ! Fill in the column from up to the level just below the surface with the input
5861 ! presssure and the input field (orig or old, which ever). For an isobaric input
5862 ! file, this data is isobaric.
5864 ! How many levels have we skipped in the input column.
5866 zap = 0
5867 zap_below = 0
5868 zap_above = 0
5870 IF ( ko_above_sfc(i) .GT. 2 ) THEN
5871 count = 1
5872 DO ko = 2 , ko_above_sfc(i)-1
5873 ordered_porig(count) = porig(i,ko,j)
5874 ordered_forig(count) = forig(i,ko,j)
5875 count = count + 1
5876 END DO
5878 ! Make sure the pressure just below the surface is not "too close", this
5879 ! will cause havoc with the higher order interpolators. In case of a "too close"
5880 ! instance, we toss out the offending level (NOT the surface one) by simply
5881 ! decrementing the accumulating loop counter.
5883 IF ( ordered_porig(count-1) - porig(i,1,j) .LT. zap_close_levels ) THEN
5884 count = count -1
5885 zap = 1
5886 zap_below = 1
5887 END IF
5889 ! Add in the surface values.
5891 ordered_porig(count) = porig(i,1,j)
5892 ordered_forig(count) = forig(i,1,j)
5893 count = count + 1
5895 ! A usual way to do the vertical interpolation is to pay more attention to the
5896 ! surface data. Why? Well it has about 20x the density as the upper air, so we
5897 ! hope the analysis is better there. We more strongly use this data by artificially
5898 ! tossing out levels above the surface that are beneath a certain number of prescribed
5899 ! eta levels at this (i,j). The "zap" value is how many levels of input we are
5900 ! removing, which is used to tell the interpolator how many valid values are in
5901 ! the column. The "count" value is the increment to the index of levels, and is
5902 ! only used for assignments.
5904 IF ( force_sfc_in_vinterp .GT. 0 ) THEN
5906 ! Get the pressure at the eta level. We want to remove all input pressure levels
5907 ! between the level above the surface to the pressure at this eta surface. That
5908 ! forces the surface value to be used through the selected eta level. Keep track
5909 ! of two things: the level to use above the eta levels, and how many levels we are
5910 ! skipping.
5912 knext = ko_above_sfc(i)
5913 find_level : DO ko = ko_above_sfc(i) , generic
5914 IF ( porig(i,ko,j) .LE. pnew(i,force_sfc_in_vinterp,j) ) THEN
5915 knext = ko
5916 exit find_level
5917 ELSE
5918 zap = zap + 1
5919 zap_above = zap_above + 1
5920 END IF
5921 END DO find_level
5923 ! No request for special interpolation, so we just assign the next level to use
5924 ! above the surface as, ta da, the first level above the surface. I know, wow.
5926 ELSE
5927 knext = ko_above_sfc(i)
5928 END IF
5930 ! One more time, make sure the pressure just above the surface is not "too close", this
5931 ! will cause havoc with the higher order interpolators. In case of a "too close"
5932 ! instance, we toss out the offending level above the surface (NOT the surface one) by simply
5933 ! incrementing the loop counter. Here, count-1 is the surface level and knext is either
5934 ! the next level up OR it is the level above the prescribed number of eta surfaces.
5936 IF ( ordered_porig(count-1) - porig(i,knext,j) .LT. zap_close_levels ) THEN
5937 kst = knext+1
5938 zap = zap + 1
5939 zap_above = zap_above + 1
5940 ELSE
5941 kst = knext
5942 END IF
5944 DO ko = kst , generic
5945 ordered_porig(count) = porig(i,ko,j)
5946 ordered_forig(count) = forig(i,ko,j)
5947 count = count + 1
5948 END DO
5950 ! This is easy, the surface is the lowest level, just stick them in, in this order. OK,
5951 ! there are a couple of subtleties. We have to check for that special interpolation that
5952 ! skips some input levels so that the surface is used for the lowest few eta levels. Also,
5953 ! we must make sure that we still do not have levels that are "too close" together.
5955 ELSE
5957 ! Initialize no input levels have yet been removed from consideration.
5959 zap = 0
5961 ! The surface is the lowest level, so it gets set right away to location 1.
5963 ordered_porig(1) = porig(i,1,j)
5964 ordered_forig(1) = forig(i,1,j)
5966 ! We start filling in the array at loc 2, as in just above the level we just stored.
5968 count = 2
5970 ! Are we forcing the interpolator to skip valid input levels so that the
5971 ! surface data is used through more levels? Essentially as above.
5973 IF ( force_sfc_in_vinterp .GT. 0 ) THEN
5974 knext = 2
5975 find_level2: DO ko = 2 , generic
5976 IF ( porig(i,ko,j) .LE. pnew(i,force_sfc_in_vinterp,j) ) THEN
5977 knext = ko
5978 exit find_level2
5979 ELSE
5980 zap = zap + 1
5981 zap_above = zap_above + 1
5982 END IF
5983 END DO find_level2
5984 ELSE
5985 knext = 2
5986 END IF
5988 ! Fill in the data above the surface. The "knext" index is either the one
5989 ! just above the surface OR it is the index associated with the level that
5990 ! is just above the pressure at this (i,j) of the top eta level that is to
5991 ! be directly impacted with the surface level in interpolation.
5993 DO ko = knext , generic
5994 IF ( ( ordered_porig(count-1) - porig(i,ko,j) .LT. zap_close_levels ) .AND. &
5995 ( ko .LT. generic ) ) THEN
5996 zap = zap + 1
5997 zap_above = zap_above + 1
5998 CYCLE
5999 END IF
6000 ordered_porig(count) = porig(i,ko,j)
6001 ordered_forig(count) = forig(i,ko,j)
6002 count = count + 1
6003 END DO
6005 END IF
6007 ! Now get the column of the "new" pressure data. So, this one is easy.
6009 DO kn = kstart , kend
6010 ordered_pnew(kn) = pnew(i,kn,j)
6011 END DO
6013 ! How many levels (count) are we shipping to the Lagrange interpolator.
6015 IF ( ( use_levels_below_ground ) .AND. ( use_surface ) ) THEN
6017 ! Use all levels, including the input surface, and including the pressure
6018 ! levels below ground. We know to stop when we have reached the top of
6019 ! the input pressure data.
6021 count = 0
6022 find_how_many_1 : DO ko = 1 , generic
6023 IF ( porig(i,generic,j) .EQ. ordered_porig(ko) ) THEN
6024 count = count + 1
6025 EXIT find_how_many_1
6026 ELSE
6027 count = count + 1
6028 END IF
6029 END DO find_how_many_1
6030 kinterp_start = 1
6031 kinterp_end = kinterp_start + count - 1
6033 ELSE IF ( ( use_levels_below_ground ) .AND. ( .NOT. use_surface ) ) THEN
6035 ! Use all levels (excluding the input surface) and including the pressure
6036 ! levels below ground. We know to stop when we have reached the top of
6037 ! the input pressure data.
6039 count = 0
6040 find_sfc_2 : DO ko = 1 , generic
6041 IF ( porig(i,1,j) .EQ. ordered_porig(ko) ) THEN
6042 sfc_level = ko
6043 EXIT find_sfc_2
6044 END IF
6045 END DO find_sfc_2
6047 DO ko = sfc_level , generic-1
6048 ordered_porig(ko) = ordered_porig(ko+1)
6049 ordered_forig(ko) = ordered_forig(ko+1)
6050 END DO
6051 ordered_porig(generic) = 1.E-5
6052 ordered_forig(generic) = 1.E10
6054 count = 0
6055 find_how_many_2 : DO ko = 1 , generic
6056 IF ( porig(i,generic,j) .EQ. ordered_porig(ko) ) THEN
6057 count = count + 1
6058 EXIT find_how_many_2
6059 ELSE
6060 count = count + 1
6061 END IF
6062 END DO find_how_many_2
6063 kinterp_start = 1
6064 kinterp_end = kinterp_start + count - 1
6066 ELSE IF ( ( .NOT. use_levels_below_ground ) .AND. ( use_surface ) ) THEN
6068 ! Use all levels above the input surface pressure.
6070 kcount = ko_above_sfc(i)-1-zap_below
6071 count = 0
6072 DO ko = 1 , generic
6073 IF ( porig(i,ko,j) .EQ. ordered_porig(kcount) ) THEN
6074 ! write (6,fmt='(f11.3,f11.3,g11.5)') porig(i,ko,j),ordered_porig(kcount),ordered_forig(kcount)
6075 kcount = kcount + 1
6076 count = count + 1
6077 ELSE
6078 ! write (6,fmt='(f11.3 )') porig(i,ko,j)
6079 END IF
6080 END DO
6081 kinterp_start = ko_above_sfc(i)-1-zap_below
6082 kinterp_end = kinterp_start + count - 1
6084 END IF
6086 ! If we have additional levels (for example, some arrays have a "level of max winds"
6087 ! or a "level of the tropopause"), we insert them here.
6089 IF ( ( flag_maxw .EQ. 1 ) .AND. ( porig_maxw(i,j) .LE. maxw_above_this_level ) ) then
6090 ok_data = .TRUE.
6091 DO jj = -2, 2
6092 DO ii = -2, 2
6093 ok_data = ok_data .AND. &
6094 ( ABS(po_maxwnn(MAX(MIN(i+ii,iend+2,ide-1),istart-2,ids),MAX(MIN(j+jj,jend+2,jde-1),jstart-2,jds))-porig_maxw(i,j)) &
6095 .LT. maxw_horiz_pres_diff )
6096 END DO
6097 END DO
6098 IF ( ok_data) THEN
6099 insert_maxw : DO ko = kinterp_start , kinterp_end-1
6100 IF ( ( ( ordered_porig(ko)-porig_maxw(i,j) ) * ( ordered_porig(ko+1)-porig_maxw(i,j) ) ) .LT. 0 ) THEN
6101 IF ( ( ABS(ordered_porig(ko )-porig_maxw(i,j)) .GT. zap_close_extra_levels ) .AND. &
6102 ( ABS(ordered_porig(ko+1)-porig_maxw(i,j)) .GT. zap_close_extra_levels ) ) THEN
6103 DO kcount = kinterp_end , ko+1 , -1
6104 ordered_porig(kcount+1) = ordered_porig(kcount)
6105 ordered_forig(kcount+1) = ordered_forig(kcount)
6106 END DO
6107 ordered_porig(ko+1) = porig_maxw(i,j)
6108 ordered_forig(ko+1) = fo_maxw(i,j)
6109 kinterp_end = kinterp_end + 1
6110 EXIT insert_maxw
6111 ELSE IF ( ABS(ordered_porig(ko )-porig_maxw(i,j)) .LE. zap_close_extra_levels ) THEN
6112 ordered_porig(ko) = porig_maxw(i,j)
6113 ordered_forig(ko) = fo_maxw(i,j)
6114 EXIT insert_maxw
6115 ELSE IF ( ABS(ordered_porig(ko+1)-porig_maxw(i,j)) .LE. zap_close_extra_levels ) THEN
6116 ordered_porig(ko+1) = porig_maxw(i,j)
6117 ordered_forig(ko+1) = fo_maxw(i,j)
6118 EXIT insert_maxw
6119 END IF
6120 END IF
6121 END DO insert_maxw
6122 END IF
6123 END IF
6125 IF ( flag_trop .EQ. 1 ) THEN
6126 ok_data = .TRUE.
6127 DO jj = -2, 2
6128 DO ii = -2, 2
6129 ok_data = ok_data .AND. &
6130 ( ABS(po_tropnn(MAX(MIN(i+ii,iend+2,ide-1),istart-2,ids),MAX(MIN(j+jj,jend+2,jde-1),jstart-2,jds))-porig_trop(i,j)) &
6131 .LT. trop_horiz_pres_diff )
6132 END DO
6133 END DO
6134 IF ( ok_data) THEN
6135 insert_trop : DO ko = kinterp_start , kinterp_end-1
6136 IF ( ( ( ordered_porig(ko)-porig_trop(i,j) ) * ( ordered_porig(ko+1)-porig_trop(i,j) ) ) .LT. 0 ) THEN
6137 IF ( ( ABS(ordered_porig(ko )-porig_trop(i,j)) .GT. zap_close_extra_levels ) .AND. &
6138 ( ABS(ordered_porig(ko+1)-porig_trop(i,j)) .GT. zap_close_extra_levels ) ) THEN
6139 DO kcount = kinterp_end , ko+1 , -1
6140 ordered_porig(kcount+1) = ordered_porig(kcount)
6141 ordered_forig(kcount+1) = ordered_forig(kcount)
6142 END DO
6143 ordered_porig(ko+1) = porig_trop(i,j)
6144 ordered_forig(ko+1) = fo_trop(i,j)
6145 kinterp_end = kinterp_end + 1
6146 EXIT insert_trop
6147 ELSE IF ( ABS(ordered_porig(ko )-porig_trop(i,j)) .LE. zap_close_extra_levels ) THEN
6148 ordered_porig(ko) = porig_trop(i,j)
6149 ordered_forig(ko) = fo_trop(i,j)
6150 EXIT insert_trop
6151 ELSE IF ( ABS(ordered_porig(ko+1)-porig_trop(i,j)) .LE. zap_close_extra_levels ) THEN
6152 ordered_porig(ko+1) = porig_trop(i,j)
6153 ordered_forig(ko+1) = fo_trop(i,j)
6154 EXIT insert_trop
6155 END IF
6156 END IF
6157 END DO insert_trop
6158 END IF
6159 END IF
6161 #if 0
6162 ! One final check to make sure that the delta pressures are OK.
6164 final_zap_check_count = 0
6165 DO ko = kinterp_start , kinterp_end-1
6167 count_close_by_at_ko = 0
6168 close_by_at_ko : DO
6170 ! First, is the pressure difference between two neighboring layers too small?
6172 IF ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .LT. zap_close_levels ) THEN
6174 ! Make sure we are vertically located where this difference is meaningful. For
6175 ! example, a 5 hPa zap_close_levels makes sense at 850 hPa. However, a 5 hPa
6176 ! critical thickness is sill when the top few isobaric levels are 1, 2, 3 hPa.
6178 IF ( ordered_porig(ko) .GT. zap_close_levels * 10 ) THEN
6180 ! Now we have a grid point that we should remove. We pull out the pressure
6181 ! and field values, then we drop the rest of the array to fill in the
6182 ! missing spot, we increment our counter of bad values found in this column,
6183 ! and then we reduce the count of the total number of values in the array.
6185 DO kn = ko+1 , kinterp_end
6186 ordered_porig(kn-1) = ordered_porig(kn)
6187 ordered_forig(kn-1) = ordered_forig(kn)
6188 END DO
6189 final_zap_check_count = final_zap_check_count + 1
6190 END IF
6191 END IF
6193 ! Did we pull down another pressure difference into the ko and ko+1 slots that will
6194 ! cause troubles? Make sure we don't spend an infinite amount of time in this loop.
6196 IF ( ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .GE. zap_close_levels ) .OR. &
6197 ( ordered_porig(ko) .LE. zap_close_levels * 10 ) ) THEN
6198 EXIT close_by_at_ko
6199 ELSE IF ( count_close_by_at_ko .GT. 3 ) THEN
6200 final_zap_check_count = 99
6201 EXIT close_by_at_ko
6202 ELSE
6203 count_close_by_at_ko = count_close_by_at_ko + 1
6204 CYCLE close_by_at_ko
6205 END IF
6206 END DO close_by_at_ko
6207 END DO
6208 IF ( final_zap_check_count .GT. 2 ) THEN
6209 WRITE ( message , * ) 'We are removing too many values: ',final_zap_check_count,' for (i,j) = ',i,j
6210 CALL wrf_error_fatal ( TRIM(message) )
6211 END IF
6212 kinterp_end = kinterp_end - final_zap_check_count
6213 #else
6214 outer : DO ko = kinterp_start , kinterp_end-1
6215 IF ( ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .LT. MAX(zap_close_levels/10,50.) ) .AND. &
6216 ( ordered_porig(ko) .GT. zap_close_levels * 10 ) ) THEN
6217 WRITE ( message , FMT='(a,I2.2,a,F9.2,a,F9.2,a,i4,a,i4,a,a)' ) '*** -> Check your wrfinput_d',id, &
6218 ' file, you might have input pressure levels too close together (',&
6219 ordered_porig(ko),' Pa and ', ordered_porig(ko+1), &
6220 ' Pa) at (',i,',',j,') for variable type ',var_type
6221 CALL wrf_message ( TRIM(message) )
6222 EXIT outer
6223 END IF
6224 END DO outer
6225 #endif
6227 ! The polynomials are either in pressure or LOG(pressure).
6229 IF ( interp_type .EQ. 1 ) THEN
6230 CALL lagrange_setup ( var_type , interp_type , &
6231 ordered_porig(kinterp_start:kinterp_end) , &
6232 ordered_forig(kinterp_start:kinterp_end) , &
6233 kinterp_end-kinterp_start+1 , lagrange_order , extrap_type , &
6234 ordered_pnew(kstart:kend) , ordered_fnew , kend-kstart+1 ,i,j)
6235 ELSE
6236 CALL lagrange_setup ( var_type , interp_type , &
6237 LOG(ordered_porig(kinterp_start:kinterp_end)) , &
6238 ordered_forig(kinterp_start:kinterp_end) , &
6239 kinterp_end-kinterp_start+1 , lagrange_order , extrap_type , &
6240 LOG(ordered_pnew(kstart:kend)) , ordered_fnew , kend-kstart+1 ,i,j)
6241 END IF
6243 ! Save the computed data.
6245 DO kn = kstart , kend
6246 fnew(i,kn,j) = ordered_fnew(kn)
6247 END DO
6249 ! There may have been a request to have the surface data from the input field
6250 ! to be assigned as to the lowest eta level. This assumes thin layers (usually
6251 ! the isobaric original field has the surface from 2-m T and RH, and 10-m U and V).
6253 IF ( lowest_lev_from_sfc ) THEN
6254 fnew(i,1,j) = forig(i,1,j)
6255 END IF
6257 END DO
6259 END DO
6261 END SUBROUTINE vert_interp
6263 !---------------------------------------------------------------------
6265 SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n , extrap_type , &
6266 target_x , target_y , target_dim ,i,j)
6268 ! We call a Lagrange polynomial interpolator. The parallel concerns are put off as this
6269 ! is initially set up for vertical use. The purpose is an input column of pressure (all_x),
6270 ! and the associated pressure level data (all_y). These are assumed to be sorted (ascending
6271 ! or descending, no matter). The locations to be interpolated to are the pressures in
6272 ! target_x, probably the new vertical coordinate values. The field that is output is the
6273 ! target_y, which is defined at the target_x location. Mostly we expect to be 2nd order
6274 ! overlapping polynomials, with only a single 2nd order method near the top and bottom.
6275 ! When n=1, this is linear; when n=2, this is a second order interpolator.
6277 IMPLICIT NONE
6279 CHARACTER (LEN=1) :: var_type
6280 INTEGER , INTENT(IN) :: interp_type , all_dim , n , extrap_type , target_dim
6281 REAL, DIMENSION(all_dim) , INTENT(IN) :: all_x , all_y
6282 REAL , DIMENSION(target_dim) , INTENT(IN) :: target_x
6283 REAL , DIMENSION(target_dim) , INTENT(OUT) :: target_y
6285 ! cubic spline defs
6286 INTEGER :: K
6287 REAL :: DX, ALPHA, BETA, GAMMA, ETA
6288 REAL , DIMENSION(all_dim) :: P2
6289 ! cubic spline defs
6291 ! Brought in for debug purposes, all of the computations are in a single column.
6293 INTEGER , INTENT(IN) :: i,j
6295 ! Local vars
6297 REAL , DIMENSION(n+1) :: x , y
6298 REAL :: a , b
6299 REAL :: target_y_1 , target_y_2
6300 LOGICAL :: found_loc
6301 INTEGER :: loop , loc_center_left , loc_center_right , ist , iend , target_loop
6302 INTEGER :: vboundb , vboundt
6304 ! Local vars for the problem of extrapolating theta below ground.
6306 REAL :: temp_1 , temp_2 , temp_3 , temp_y
6307 REAL :: depth_of_extrap_in_p , avg_of_extrap_p , temp_extrap_starting_point , dhdp , dh , dt
6308 #ifdef VERT_UNIT
6309 REAL , PARAMETER :: RovCp = 0.287
6310 #else
6311 REAL , PARAMETER :: RovCp = rcp
6312 #endif
6313 REAL , PARAMETER :: CRC_const1 = 11880.516 ! m
6314 REAL , PARAMETER :: CRC_const2 = 0.1902632 !
6315 REAL , PARAMETER :: CRC_const3 = 0.0065 ! K/km
6316 REAL, DIMENSION(all_dim) :: all_x_full
6317 REAL , DIMENSION(target_dim) :: target_x_full
6319 IF ( all_dim .LT. n+1 ) THEN
6320 print *,'all_dim = ',all_dim
6321 print *,'order = ',n
6322 print *,'i,j = ',i,j
6323 print *,'p array = ',all_x
6324 print *,'f array = ',all_y
6325 print *,'p target= ',target_x
6326 CALL wrf_message ( 0 , 'Troubles, the interpolating order is too large for this few input values' )
6327 CALL wrf_message ( 0 , 'This is usually caused by bad pressures' )
6328 CALL wrf_message ( 0 , 'At this (i,j), look at the input value of pressure from metgrid' )
6329 CALL wrf_message ( 0 , 'The surface pressure and the sea-level pressure should be reviewed, also from metgrid' )
6330 CALL wrf_message ( 0 , 'Finally, ridiculous values of moisture can mess up the vertical pressures, especially aloft' )
6331 CALL wrf_message ( 0 , 'The variable type is ' // var_type // '. This is not a unique identifer, but a type of field' )
6332 CALL wrf_message ( 0 , 'Check to see if all time periods with this data fail, or just this one' )
6333 CALL wrf_error_fatal ( 'This vertical interpolation failure is more typically associated with untested data sources to ungrib' )
6334 END IF
6336 IF ( n .LT. 1 ) THEN
6337 CALL wrf_error_fatal ( 'pal, linear is about as low as we go' )
6338 END IF
6340 ! We can pinch in the area of the higher order interpolation with vbound. If
6341 ! vbound = 0, no pinching. If vbound = m, then we make the lower "m" and upper
6342 ! "m" eta levels use a linear interpolation.
6344 vboundb = 4
6345 vboundt = 0
6347 ! Loop over the list of target x and y values.
6349 DO target_loop = 1 , target_dim
6351 ! Find the two trapping x values, and keep the indices.
6353 found_loc = .FALSE.
6354 find_trap : DO loop = 1 , all_dim -1
6355 a = target_x(target_loop) - all_x(loop)
6356 b = target_x(target_loop) - all_x(loop+1)
6357 IF ( a*b .LE. 0.0 ) THEN
6358 loc_center_left = loop
6359 loc_center_right = loop+1
6360 found_loc = .TRUE.
6361 EXIT find_trap
6362 END IF
6363 END DO find_trap
6365 IF ( ( .NOT. found_loc ) .AND. ( target_x(target_loop) .GT. all_x(1) ) ) THEN
6367 ! Get full pressure back so that our extrpolations make sense.
6369 IF ( interp_type .EQ. 1 ) THEN
6370 all_x_full = all_x
6371 target_x_full = target_x
6372 ELSE
6373 all_x_full = EXP ( all_x )
6374 target_x_full = EXP ( target_x )
6375 END IF
6376 ! Isothermal extrapolation.
6378 IF ( ( extrap_type .EQ. 1 ) .AND. ( var_type .EQ. 'T' ) ) THEN
6380 temp_1 = all_y(1) * ( all_x_full(1) / 100000. ) ** RovCp
6381 target_y(target_loop) = temp_1 * ( 100000. / target_x_full(target_loop) ) ** RovCp
6383 ! Standard atmosphere -6.5 K/km lapse rate for the extrapolation.
6385 ELSE IF ( ( extrap_type .EQ. 2 ) .AND. ( var_type .EQ. 'T' ) ) THEN
6387 depth_of_extrap_in_p = target_x_full(target_loop) - all_x_full(1)
6388 avg_of_extrap_p = ( target_x_full(target_loop) + all_x_full(1) ) * 0.5
6389 temp_extrap_starting_point = all_y(1) * ( all_x_full(1) / 100000. ) ** RovCp
6390 dhdp = CRC_const1 * CRC_const2 * ( avg_of_extrap_p / 100. ) ** ( CRC_const2 - 1. )
6391 dh = dhdp * ( depth_of_extrap_in_p / 100. )
6392 dt = dh * CRC_const3
6393 target_y(target_loop) = ( temp_extrap_starting_point + dt ) * ( 100000. / target_x_full(target_loop) ) ** RovCp
6395 ! Adiabatic extrapolation for theta.
6397 ELSE IF ( ( extrap_type .EQ. 3 ) .AND. ( var_type .EQ. 'T' ) ) THEN
6399 target_y(target_loop) = all_y(1)
6402 ! Wild extrapolation for non-temperature vars.
6404 ELSE IF ( extrap_type .EQ. 1 ) THEN
6406 target_y(target_loop) = ( all_y(2) * ( target_x(target_loop) - all_x(3) ) + &
6407 all_y(3) * ( all_x(2) - target_x(target_loop) ) ) / &
6408 ( all_x(2) - all_x(3) )
6410 ! Use a constant value below ground.
6412 ELSE IF ( extrap_type .EQ. 2 ) THEN
6414 target_y(target_loop) = all_y(1)
6416 ELSE IF ( extrap_type .EQ. 3 ) THEN
6417 CALL wrf_error_fatal ( 'You are not allowed to use extrap_option #3 for any var except for theta.' )
6419 END IF
6420 CYCLE
6421 ELSE IF ( .NOT. found_loc ) THEN
6422 print *,'i,j = ',i,j
6423 print *,'target pressure and value = ',target_x(target_loop),target_y(target_loop)
6424 DO loop = 1 , all_dim
6425 print *,'column of pressure and value = ',all_x(loop),all_y(loop)
6426 END DO
6427 CALL wrf_error_fatal ( 'troubles, could not find trapping x locations' )
6428 END IF
6430 ! Even or odd order? We can put the value in the middle if this is
6431 ! an odd order interpolator. For the even guys, we'll do it twice
6432 ! and shift the range one index, then get an average.
6434 IF ( n .EQ. 9 ) THEN
6435 CALL cubic_spline (all_dim-1, all_x, all_y, P2)
6436 !
6437 ! Find the value of function f(x)
6438 !
6439 DX = all_x(loc_center_right) - all_x(loc_center_left)
6440 ALPHA = P2(loc_center_right)/(6*DX)
6441 BETA = -P2(loc_center_left)/(6*DX)
6442 GAMMA = all_y(loc_center_right)/DX - DX*P2(loc_center_right)/6
6443 ETA = DX*P2(loc_center_left)/6 - all_y(loc_center_left)/DX
6444 target_y(target_loop) = ALPHA*(target_x(target_loop)-all_x(loc_center_left))*(target_x(target_loop)-all_x(loc_center_left)) &
6445 *(target_x(target_loop)-all_x(loc_center_left)) &
6446 +BETA*(target_x(target_loop)-all_x(loc_center_right))*(target_x(target_loop)-all_x(loc_center_right)) &
6447 *(target_x(target_loop)-all_x(loc_center_right)) &
6448 +GAMMA*(target_x(target_loop)-all_x(loc_center_left)) &
6449 +ETA*(target_x(target_loop)-all_x(loc_center_right))
6451 ELSE IF ( MOD(n,2) .NE. 0 ) THEN
6452 IF ( ( loc_center_left -(((n+1)/2)-1) .GE. 1 ) .AND. &
6453 ( loc_center_right+(((n+1)/2)-1) .LE. all_dim ) ) THEN
6454 ist = loc_center_left -(((n+1)/2)-1)
6455 iend = ist + n
6456 CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop) )
6457 ELSE
6458 IF ( .NOT. found_loc ) THEN
6459 CALL wrf_error_fatal ( 'I doubt this will happen, I will only do 2nd order for now' )
6460 END IF
6461 END IF
6463 ELSE IF ( ( MOD(n,2) .EQ. 0 ) .AND. &
6464 ( ( target_loop .GE. 1 + vboundb ) .AND. ( target_loop .LE. target_dim - vboundt ) ) ) THEN
6465 IF ( ( loc_center_left -(((n )/2)-1) .GE. 1 ) .AND. &
6466 ( loc_center_right+(((n )/2) ) .LE. all_dim ) .AND. &
6467 ( loc_center_left -(((n )/2) ) .GE. 1 ) .AND. &
6468 ( loc_center_right+(((n )/2)-1) .LE. all_dim ) ) THEN
6469 ist = loc_center_left -(((n )/2)-1)
6470 iend = ist + n
6471 CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y_1 )
6472 ist = loc_center_left -(((n )/2) )
6473 iend = ist + n
6474 CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y_2 )
6475 target_y(target_loop) = ( target_y_1 + target_y_2 ) * 0.5
6477 ELSE IF ( ( loc_center_left -(((n )/2)-1) .GE. 1 ) .AND. &
6478 ( loc_center_right+(((n )/2) ) .LE. all_dim ) ) THEN
6479 ist = loc_center_left -(((n )/2)-1)
6480 iend = ist + n
6481 CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop) )
6482 ELSE IF ( ( loc_center_left -(((n )/2) ) .GE. 1 ) .AND. &
6483 ( loc_center_right+(((n )/2)-1) .LE. all_dim ) ) THEN
6484 ist = loc_center_left -(((n )/2) )
6485 iend = ist + n
6486 CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop) )
6487 ELSE
6488 CALL wrf_error_fatal ( 'unauthorized area, you should not be here' )
6489 END IF
6491 ELSE IF ( MOD(n,2) .EQ. 0 ) THEN
6492 ist = loc_center_left
6493 iend = loc_center_right
6494 CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , 1 , target_x(target_loop) , target_y(target_loop) )
6496 END IF
6498 END DO
6500 END SUBROUTINE lagrange_setup
6502 !---------------------------------------------------------------------
6504 ! cubic spline routines
6506 SUBROUTINE cubic_spline (N, XI, FI, P2)
6507 !
6508 ! Function to carry out the cubic-spline approximation
6509 ! with the second-order derivatives returned.
6510 !
6511 INTEGER :: I
6512 INTEGER, INTENT (IN) :: N
6513 REAL, INTENT (IN), DIMENSION (N+1):: XI, FI
6514 REAL, INTENT (OUT), DIMENSION (N+1):: P2
6515 REAL, DIMENSION (N):: G, H
6516 REAL, DIMENSION (N-1):: D, B, C
6517 !
6518 ! Assign the intervals and function differences
6519 !
6520 DO I = 1, N
6521 H(I) = XI(I+1) - XI(I)
6522 G(I) = FI(I+1) - FI(I)
6523 END DO
6524 !
6525 ! Evaluate the coefficient matrix elements
6526 DO I = 1, N-1
6527 D(I) = 2*(H(I+1)+H(I))
6528 B(I) = 6*(G(I+1)/H(I+1)-G(I)/H(I))
6529 C(I) = H(I+1)
6530 END DO
6531 !
6532 ! Obtain the second-order derivatives
6533 !
6534 CALL TRIDIAGONAL_LINEAR_EQ (N-1, D, C, C, B, G)
6535 P2(1) = 0
6536 P2(N+1) = 0
6537 DO I = 2, N
6538 P2(I) = G(I-1)
6539 END DO
6541 END SUBROUTINE cubic_spline
6543 !---------------------------------------------------------------------
6545 SUBROUTINE TRIDIAGONAL_LINEAR_EQ (L, D, E, C, B, Z)
6546 !
6547 ! Function to solve the tridiagonal linear equation set.
6548 !
6549 INTEGER, INTENT (IN) :: L
6550 INTEGER :: I
6551 REAL, INTENT (IN), DIMENSION (L):: D, E, C, B
6552 REAL, INTENT (OUT), DIMENSION (L):: Z
6553 REAL, DIMENSION (L):: Y, W
6554 REAL, DIMENSION (L-1):: V, T
6555 !
6556 ! Evaluate the elements in the LU decomposition
6557 !
6558 W(1) = D(1)
6559 V(1) = C(1)
6560 T(1) = E(1)/W(1)
6561 DO I = 2, L - 1
6562 W(I) = D(I)-V(I-1)*T(I-1)
6563 V(I) = C(I)
6564 T(I) = E(I)/W(I)
6565 END DO
6566 W(L) = D(L)-V(L-1)*T(L-1)
6567 !
6568 ! Forward substitution to obtain y
6569 !
6570 Y(1) = B(1)/W(1)
6571 DO I = 2, L
6572 Y(I) = (B(I)-V(I-1)*Y(I-1))/W(I)
6573 END DO
6574 !
6575 ! Backward substitution to obtain z
6576 Z(L) = Y(L)
6577 DO I = L-1, 1, -1
6578 Z(I) = Y(I) - T(I)*Z(I+1)
6579 END DO
6581 END SUBROUTINE TRIDIAGONAL_LINEAR_EQ
6583 ! end cubic spline routines
6585 !---------------------------------------------------------------------
6587 SUBROUTINE lagrange_interp ( x , y , n , target_x , target_y )
6589 ! Interpolation using Lagrange polynomials.
6590 ! P(x) = f(x0)Ln0(x) + ... + f(xn)Lnn(x)
6591 ! where Lnk(x) = (x -x0)(x -x1)...(x -xk-1)(x -xk+1)...(x -xn)
6592 ! ---------------------------------------------
6593 ! (xk-x0)(xk-x1)...(xk-xk-1)(xk-xk+1)...(xk-xn)
6595 IMPLICIT NONE
6597 INTEGER , INTENT(IN) :: n
6598 REAL , DIMENSION(0:n) , INTENT(IN) :: x , y
6599 REAL , INTENT(IN) :: target_x
6601 REAL , INTENT(OUT) :: target_y
6603 ! Local vars
6605 INTEGER :: i , k
6606 REAL :: numer , denom , Px
6607 REAL , DIMENSION(0:n) :: Ln
6609 Px = 0.
6610 DO i = 0 , n
6611 numer = 1.
6612 denom = 1.
6613 DO k = 0 , n
6614 IF ( k .EQ. i ) CYCLE
6615 numer = numer * ( target_x - x(k) )
6616 denom = denom * ( x(i) - x(k) )
6617 END DO
6618 IF ( denom .NE. 0. ) THEN
6619 Ln(i) = y(i) * numer / denom
6620 Px = Px + Ln(i)
6621 ENDIF
6622 END DO
6623 target_y = Px
6625 END SUBROUTINE lagrange_interp
6627 #ifndef VERT_UNIT
6628 !---------------------------------------------------------------------
6630 SUBROUTINE p_dry ( mu0 , eta , pdht , pdry , full_levs , &
6631 c3f , c3h , c4f , c4h , &
6632 ids , ide , jds , jde , kds , kde , &
6633 ims , ime , jms , jme , kms , kme , &
6634 its , ite , jts , jte , kts , kte )
6636 ! Compute reference pressure and the reference mu.
6638 IMPLICIT NONE
6640 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
6641 ims , ime , jms , jme , kms , kme , &
6642 its , ite , jts , jte , kts , kte
6644 LOGICAL :: full_levs
6646 REAL , DIMENSION(ims:ime, jms:jme) , INTENT(IN) :: mu0
6647 REAL , DIMENSION( kms:kme ) , INTENT(IN) :: eta
6648 REAL , DIMENSION( kms:kme ) , INTENT(IN) :: c3f , c3h , c4f , c4h
6649 REAL :: pdht
6650 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: pdry
6652 ! Local vars
6654 INTEGER :: i , j , k
6655 REAL , DIMENSION( kms:kme ) :: eta_h
6657 IF ( full_levs ) THEN
6658 DO j = jts , MIN ( jde-1 , jte )
6659 DO k = kts , kte
6660 DO i = its , MIN (ide-1 , ite )
6661 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6662 pdry(i,k,j) = c3f(k) * MU0(i,j) + c4f(k) + pdht
6663 END DO
6664 END DO
6665 END DO
6666 ELSE
6667 DO k = kts , kte-1
6668 eta_h(k) = ( eta(k) + eta(k+1) ) * 0.5
6669 END DO
6670 DO j = jts , MIN ( jde-1 , jte )
6671 DO k = kts , kte-1
6672 DO i = its , MIN (ide-1 , ite )
6673 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6674 pdry(i,k,j) = c3h(k) * MU0(i,j) + c4h(k) + pdht
6675 END DO
6676 END DO
6677 END DO
6678 END IF
6680 END SUBROUTINE p_dry
6682 !---------------------------------------------------------------------
6684 SUBROUTINE p_dts ( pdts , intq , psfc , p_top , &
6685 ids , ide , jds , jde , kds , kde , &
6686 ims , ime , jms , jme , kms , kme , &
6687 its , ite , jts , jte , kts , kte )
6689 ! Compute difference between the dry, total surface pressure and the top pressure.
6691 IMPLICIT NONE
6693 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
6694 ims , ime , jms , jme , kms , kme , &
6695 its , ite , jts , jte , kts , kte
6697 REAL , INTENT(IN) :: p_top
6698 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: psfc
6699 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: intq
6700 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: pdts
6702 ! Local vars
6704 INTEGER :: i , j , k
6706 DO j = jts , MIN ( jde-1 , jte )
6707 DO i = its , MIN (ide-1 , ite )
6708 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6709 pdts(i,j) = psfc(i,j) - intq(i,j) - p_top
6710 END DO
6711 END DO
6713 END SUBROUTINE p_dts
6715 !---------------------------------------------------------------------
6717 SUBROUTINE p_dhs ( pdhs , ht , p0 , t0 , a , &
6718 ids , ide , jds , jde , kds , kde , &
6719 ims , ime , jms , jme , kms , kme , &
6720 its , ite , jts , jte , kts , kte )
6722 ! Compute dry, hydrostatic surface pressure.
6724 IMPLICIT NONE
6726 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
6727 ims , ime , jms , jme , kms , kme , &
6728 its , ite , jts , jte , kts , kte
6730 REAL , DIMENSION(ims:ime, jms:jme) , INTENT(IN) :: ht
6731 REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: pdhs
6733 REAL , INTENT(IN) :: p0 , t0 , a
6735 ! Local vars
6737 INTEGER :: i , j , k
6739 REAL , PARAMETER :: Rd = r_d
6741 DO j = jts , MIN ( jde-1 , jte )
6742 DO i = its , MIN (ide-1 , ite )
6743 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6744 pdhs(i,j) = p0 * EXP ( -t0/a + SQRT ( (t0/a)**2 - 2. * g * ht(i,j)/(a * Rd) ) )
6745 END DO
6746 END DO
6748 END SUBROUTINE p_dhs
6750 !---------------------------------------------------------------------
6752 SUBROUTINE find_p_top ( p , p_top , &
6753 ids , ide , jds , jde , kds , kde , &
6754 ims , ime , jms , jme , kms , kme , &
6755 its , ite , jts , jte , kts , kte )
6757 ! Find the largest pressure in the top level. This is our p_top. We are
6758 ! assuming that the top level is the location where the pressure is a minimum
6759 ! for each column. In cases where the top surface is not isobaric, a
6760 ! communicated value must be shared in the calling routine. Also in cases
6761 ! where the top surface is not isobaric, care must be taken that the new
6762 ! maximum pressure is not greater than the previous value. This test is
6763 ! also handled in the calling routine.
6765 IMPLICIT NONE
6767 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
6768 ims , ime , jms , jme , kms , kme , &
6769 its , ite , jts , jte , kts , kte
6771 REAL :: p_top
6772 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p
6774 ! Local vars
6776 INTEGER :: i , j , k, min_lev
6778 i = its
6779 j = jts
6780 p_top = p(i,2,j)
6781 min_lev = 2
6782 DO k = 2 , kte
6783 IF ( p_top .GT. p(i,k,j) ) THEN
6784 p_top = p(i,k,j)
6785 min_lev = k
6786 END IF
6787 END DO
6789 k = min_lev
6790 p_top = p(its,k,jts)
6791 DO j = jts , MIN ( jde-1 , jte )
6792 DO i = its , MIN (ide-1 , ite )
6793 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6794 p_top = MAX ( p_top , p(i,k,j) )
6795 END DO
6796 END DO
6798 END SUBROUTINE find_p_top
6800 !---------------------------------------------------------------------
6802 SUBROUTINE t_to_theta ( t , p , p00 , &
6803 ids , ide , jds , jde , kds , kde , &
6804 ims , ime , jms , jme , kms , kme , &
6805 its , ite , jts , jte , kts , kte )
6807 ! Compute potential temperature from temperature and pressure.
6809 IMPLICIT NONE
6811 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
6812 ims , ime , jms , jme , kms , kme , &
6813 its , ite , jts , jte , kts , kte
6815 REAL , INTENT(IN) :: p00
6816 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p
6817 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: t
6819 ! Local vars
6821 INTEGER :: i , j , k
6823 REAL , PARAMETER :: Rd = r_d
6825 DO j = jts , MIN ( jde-1 , jte )
6826 DO k = kts , kte
6827 DO i = its , MIN (ide-1 , ite )
6828 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6829 t(i,k,j) = t(i,k,j) * ( p00 / p(i,k,j) ) ** (Rd / Cp)
6830 END DO
6831 END DO
6832 END DO
6834 END SUBROUTINE t_to_theta
6837 !---------------------------------------------------------------------
6839 SUBROUTINE theta_to_t ( t , p , p00 , &
6840 ids , ide , jds , jde , kds , kde , &
6841 ims , ime , jms , jme , kms , kme , &
6842 its , ite , jts , jte , kts , kte )
6844 ! Compute temperature from potential temp and pressure.
6846 IMPLICIT NONE
6848 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
6849 ims , ime , jms , jme , kms , kme , &
6850 its , ite , jts , jte , kts , kte
6852 REAL , INTENT(IN) :: p00
6853 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p
6854 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: t
6856 ! Local vars
6858 INTEGER :: i , j , k
6860 REAL , PARAMETER :: Rd = r_d
6861 CHARACTER (LEN=80) :: mess
6863 DO j = jts , MIN ( jde-1 , jte )
6864 DO k = kts , kte-1
6865 DO i = its , MIN (ide-1 , ite )
6866 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6867 if ( p(i,k,j) .NE. 0. ) then
6868 t(i,k,j) = t(i,k,j) / ( ( p00 / p(i,k,j) ) ** (Rd / Cp) )
6869 else
6870 WRITE(mess,*) 'Troubles in theta_to_t'
6871 CALL wrf_debug(0,mess)
6872 WRITE(mess,*) "i,j,k = ", i,j,k
6873 CALL wrf_debug(0,mess)
6874 WRITE(mess,*) "p(i,k,j) = ", p(i,k,j)
6875 CALL wrf_debug(0,mess)
6876 WRITE(mess,*) "t(i,k,j) = ", t(i,k,j)
6877 CALL wrf_debug(0,mess)
6878 endif
6879 END DO
6880 END DO
6881 END DO
6883 END SUBROUTINE theta_to_t
6885 !---------------------------------------------------------------------
6887 SUBROUTINE integ_moist ( q_in , p_in , pd_out , t_in , ght_in , intq , &
6888 ids , ide , jds , jde , kds , kde , &
6889 ims , ime , jms , jme , kms , kme , &
6890 its , ite , jts , jte , kts , kte )
6892 ! Integrate the moisture field vertically. Mostly used to get the total
6893 ! vapor pressure, which can be subtracted from the total pressure to get
6894 ! the dry pressure.
6896 IMPLICIT NONE
6898 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
6899 ims , ime , jms , jme , kms , kme , &
6900 its , ite , jts , jte , kts , kte
6902 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: q_in , p_in , t_in , ght_in
6903 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: pd_out
6904 REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: intq
6906 ! Local vars
6908 INTEGER :: i , j , k
6909 INTEGER , DIMENSION(ims:ime) :: level_above_sfc
6910 REAL , DIMENSION(ims:ime,jms:jme) :: psfc , tsfc , qsfc, zsfc
6911 REAL , DIMENSION(ims:ime,kms:kme) :: q , p , t , ght, pd
6913 REAL :: rhobar , qbar , dz
6914 REAL :: p1 , p2 , t1 , t2 , q1 , q2 , z1, z2
6916 LOGICAL :: upside_down
6917 LOGICAL :: already_assigned_upside_down
6919 REAL , PARAMETER :: Rd = r_d
6921 ! Is the data upside down?
6924 already_assigned_upside_down = .FALSE.
6925 find_valid : DO j = jts , MIN ( jde-1 , jte )
6926 DO i = its , MIN (ide-1 , ite )
6927 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6928 IF ( p_in(i,kts+1,j) .LT. p_in(i,kte,j) ) THEN
6929 upside_down = .TRUE.
6930 already_assigned_upside_down = .TRUE.
6931 ELSE
6932 upside_down = .FALSE.
6933 already_assigned_upside_down = .TRUE.
6934 END IF
6935 EXIT find_valid
6936 END DO
6937 END DO find_valid
6939 IF ( .NOT. already_assigned_upside_down ) THEN
6940 upside_down = .FALSE.
6941 END IF
6943 ! Get a surface value, always the first level of a 3d field.
6945 DO j = jts , MIN ( jde-1 , jte )
6946 DO i = its , MIN (ide-1 , ite )
6947 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6948 psfc(i,j) = p_in(i,kts,j)
6949 tsfc(i,j) = t_in(i,kts,j)
6950 qsfc(i,j) = q_in(i,kts,j)
6951 zsfc(i,j) = ght_in(i,kts,j)
6952 END DO
6953 END DO
6955 DO j = jts , MIN ( jde-1 , jte )
6957 ! Initialize the integrated quantity of moisture to zero.
6959 DO i = its , MIN (ide-1 , ite )
6960 intq(i,j) = 0.
6961 END DO
6963 IF ( upside_down ) THEN
6964 DO i = its , MIN (ide-1 , ite )
6965 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6966 p(i,kts) = p_in(i,kts,j)
6967 t(i,kts) = t_in(i,kts,j)
6968 q(i,kts) = q_in(i,kts,j)
6969 ght(i,kts) = ght_in(i,kts,j)
6970 DO k = kts+1,kte
6971 p(i,k) = p_in(i,kte+2-k,j)
6972 t(i,k) = t_in(i,kte+2-k,j)
6973 q(i,k) = q_in(i,kte+2-k,j)
6974 ght(i,k) = ght_in(i,kte+2-k,j)
6975 END DO
6976 END DO
6977 ELSE
6978 DO i = its , MIN (ide-1 , ite )
6979 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6980 DO k = kts,kte
6981 p(i,k) = p_in(i,k ,j)
6982 t(i,k) = t_in(i,k ,j)
6983 q(i,k) = q_in(i,k ,j)
6984 ght(i,k) = ght_in(i,k ,j)
6985 END DO
6986 END DO
6987 END IF
6989 ! Find the first level above the ground. If all of the levels are above ground, such as
6990 ! a terrain following lower coordinate, then the first level above ground is index #2.
6992 DO i = its , MIN (ide-1 , ite )
6993 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
6994 level_above_sfc(i) = -1
6995 IF ( p(i,kts+1) .LT. psfc(i,j) ) THEN
6996 level_above_sfc(i) = kts+1
6997 ELSE
6998 find_k : DO k = kts+1,kte-1
6999 IF ( ( p(i,k )-psfc(i,j) .GE. 0. ) .AND. &
7000 ( p(i,k+1)-psfc(i,j) .LT. 0. ) ) THEN
7001 level_above_sfc(i) = k+1
7002 EXIT find_k
7003 END IF
7004 END DO find_k
7005 IF ( level_above_sfc(i) .EQ. -1 ) THEN
7006 print *,'i,j = ',i,j
7007 print *,'p = ',p(i,:)
7008 print *,'p sfc = ',psfc(i,j)
7009 CALL wrf_error_fatal ( 'Could not find level above ground')
7010 END IF
7011 END IF
7012 END DO
7014 DO i = its , MIN (ide-1 , ite )
7015 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7017 ! Account for the moisture above the ground.
7019 pd(i,kte) = p(i,kte)
7020 DO k = kte-1,level_above_sfc(i),-1
7021 rhobar = ( p(i,k ) / ( Rd * t(i,k ) ) + &
7022 p(i,k+1) / ( Rd * t(i,k+1) ) ) * 0.5
7023 qbar = ( q(i,k ) + q(i,k+1) ) * 0.5
7024 dz = ght(i,k+1) - ght(i,k)
7025 intq(i,j) = intq(i,j) + g * qbar * rhobar / (1. + qbar) * dz
7026 pd(i,k) = p(i,k) - intq(i,j)
7027 END DO
7029 ! Account for the moisture between the surface and the first level up.
7031 IF ( ( p(i,level_above_sfc(i)-1)-psfc(i,j) .GE. 0. ) .AND. &
7032 ( p(i,level_above_sfc(i) )-psfc(i,j) .LT. 0. ) .AND. &
7033 ( level_above_sfc(i) .GT. kts ) ) THEN
7034 p1 = psfc(i,j)
7035 p2 = p(i,level_above_sfc(i))
7036 t1 = tsfc(i,j)
7037 t2 = t(i,level_above_sfc(i))
7038 q1 = qsfc(i,j)
7039 q2 = q(i,level_above_sfc(i))
7040 z1 = zsfc(i,j)
7041 z2 = ght(i,level_above_sfc(i))
7042 rhobar = ( p1 / ( Rd * t1 ) + &
7043 p2 / ( Rd * t2 ) ) * 0.5
7044 qbar = ( q1 + q2 ) * 0.5
7045 dz = z2 - z1
7046 IF ( dz .GT. 0.1 ) THEN
7047 intq(i,j) = intq(i,j) + g * qbar * rhobar / (1. + qbar) * dz
7048 END IF
7050 ! Fix the underground values.
7052 DO k = level_above_sfc(i)-1,kts+1,-1
7053 pd(i,k) = p(i,k) - intq(i,j)
7054 END DO
7055 END IF
7056 pd(i,kts) = psfc(i,j) - intq(i,j)
7058 END DO
7060 IF ( upside_down ) THEN
7061 DO i = its , MIN (ide-1 , ite )
7062 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7063 pd_out(i,kts,j) = pd(i,kts)
7064 DO k = kts+1,kte
7065 pd_out(i,kte+2-k,j) = pd(i,k)
7066 END DO
7067 END DO
7068 ELSE
7069 DO i = its , MIN (ide-1 , ite )
7070 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7071 DO k = kts,kte
7072 pd_out(i,k,j) = pd(i,k)
7073 END DO
7074 END DO
7075 END IF
7077 END DO
7079 END SUBROUTINE integ_moist
7081 !---------------------------------------------------------------------
7083 SUBROUTINE rh_to_mxrat2(rh, t, p, q , wrt_liquid , &
7084 qv_max_p_safe , &
7085 qv_max_flag , qv_max_value , &
7086 qv_min_p_safe , &
7087 qv_min_flag , qv_min_value , &
7088 ids , ide , jds , jde , kds , kde , &
7089 ims , ime , jms , jme , kms , kme , &
7090 its , ite , jts , jte , kts , kte )
7092 ! This subroutine computes mixing ratio (q, kg/kg) from basic variables
7093 ! pressure (p, Pa), temperature (t, K) and relative humidity (rh, 0-100%).
7094 ! Phase transition, liquid water to ice, occurs over (0,-23) temperature range (Celcius).
7095 ! Formulation used here is based on:
7096 ! WMO, General meteorological standards and recommended practices,
7097 ! Appendix A, WMO Technical Regulations, WMO-No. 49, corrigendum,
7098 ! August 2000. --TKW 03/30/2011
7100 IMPLICIT NONE
7102 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
7103 ims , ime , jms , jme , kms , kme , &
7104 its , ite , jts , jte , kts , kte
7106 LOGICAL , INTENT(IN) :: wrt_liquid
7108 REAL , INTENT(IN) :: qv_max_p_safe , qv_max_flag , qv_max_value
7109 REAL , INTENT(IN) :: qv_min_p_safe , qv_min_flag , qv_min_value
7111 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p , t
7112 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: rh
7113 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: q
7115 ! Local vars
7117 REAL, PARAMETER :: T0K = 273.16
7118 REAL, PARAMETER :: Tice = T0K - 23.0
7120 REAL, PARAMETER :: cfe = 1.0/(23.0*23.0)
7121 REAL, PARAMETER :: eps = 0.622
7123 ! Coefficients for esat over liquid water
7124 REAL, PARAMETER :: cw1 = 10.79574
7125 REAL, PARAMETER :: cw2 = -5.02800
7126 REAL, PARAMETER :: cw3 = 1.50475E-4
7127 REAL, PARAMETER :: cw4 = 0.42873E-3
7128 REAL, PARAMETER :: cw5 = 0.78614
7130 ! Coefficients for esat over ice
7131 REAL, PARAMETER :: ci1 = -9.09685
7132 REAL, PARAMETER :: ci2 = -3.56654
7133 REAL, PARAMETER :: ci3 = 0.87682
7134 REAL, PARAMETER :: ci4 = 0.78614
7136 REAL, PARAMETER :: Tn = 273.16
7138 ! 1 ppm is a reasonable estimate for minimum QV even for stratospheric altitudes
7139 REAL, PARAMETER :: QV_MIN = 1.e-6
7141 ! Maximum allowed QV is computed under the extreme condition:
7142 ! Saturated at 40 degree in Celcius and 1000 hPa
7143 REAL, PARAMETER :: QV_MAX = 0.045
7145 ! Need to constrain WVP in the stratosphere where pressure
7146 ! is low but tempearure is hot (warm)
7147 ! Maximum ratio of e/p, = q/(0.622+q)
7148 REAL, PARAMETER :: EP_MAX = QV_MAX/(eps+QV_MAX)
7150 INTEGER :: i , j , k
7152 REAL :: ew , q1 , t1
7153 REAL :: ta, tb, pw3, pw4, pwr
7154 REAL :: es, esw, esi, wvp, pmb, wvpmax
7156 DO j = jts , MIN ( jde-1 , jte )
7157 DO k = kts , kte
7158 DO i = its , MIN (ide-1 , ite )
7159 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7160 rh(i,k,j) = MIN ( MAX ( rh(i,k,j) , 0. ) , 100. )
7161 END DO
7162 END DO
7163 END DO
7165 IF ( wrt_liquid ) THEN
7166 DO j = jts , MIN ( jde-1 , jte )
7167 DO k = kts , kte
7168 DO i = its , MIN (ide-1 , ite )
7169 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7170 Ta=Tn/T(i,k,j)
7171 Tb=T(i,k,j)/Tn
7172 pw3 = -8.2969*(Tb-1.0)
7173 pw4 = 4.76955*(1.0-Ta)
7174 pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5
7175 es = 10.0**pwr ! Saturation WVP
7176 wvp = 0.01*rh(i,k,j)*es ! Actual WVP
7177 pmb = p(i,k,j)/100.
7178 wvpmax = EP_MAX*pmb ! Prevents unrealistic QV in the stratosphere
7179 wvp = MIN(wvp,wvpmax)
7180 q(i,k,j) = eps*wvp/(pmb-wvp)
7181 END DO
7182 END DO
7183 END DO
7185 ELSE
7186 DO j = jts , MIN ( jde-1 , jte )
7187 DO k = kts , kte
7188 DO i = its , MIN (ide-1 , ite )
7189 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7190 Ta=Tn/T(i,k,j)
7191 Tb=T(i,k,j)/Tn
7192 IF (t(i,k,j) >= T0K) THEN ! Over liquid water
7193 pw3 = -8.2969*(Tb-1.0)
7194 pw4 = 4.76955*(1.0-Ta)
7195 pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5
7196 es = 10.0**pwr
7197 wvp = 0.01*rh(i,k,j)*es
7198 ELSE IF (t(i,k,j) <= Tice) THEN ! Over ice
7199 pwr = ci1*(Ta-1.0) + ci2*LOG10(Ta) + ci3*(1.0-Tb) + ci4
7200 es = 10.0**pwr
7201 wvp = 0.01*rh(i,k,j)*es
7202 ELSE ! Mixed
7203 pw3 = -8.2969*(Tb-1.0)
7204 pw4 = 4.76955*(1.0-Ta)
7205 pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5
7206 esw = 10.0**pwr ! Over liquid water
7208 pwr = ci1*(Ta-1.0) + ci2*LOG10(Ta) + ci3*(1.0-Tb) + ci4
7209 esi = 10.0**pwr ! Over ice
7211 es = esi + (esw-esi)*cfe*(T(i,k,j)-Tice)*(T(i,k,j)-Tice)
7212 wvp = 0.01*rh(i,k,j)*es
7213 END IF
7214 pmb = p(i,k,j)/100.
7215 wvpmax = EP_MAX*pmb ! Prevents unrealistic QV in the stratosphere
7216 wvp = MIN(wvp,wvpmax)
7217 q(i,k,j) = eps*wvp/(pmb-wvp)
7218 END DO
7219 END DO
7220 END DO
7221 END IF
7223 ! For pressures above a defined level, reasonable Qv values should be
7224 ! a certain value or smaller. If they are larger than this, the input data
7225 ! probably had "missing" RH, and we filled in some values. This is an
7226 ! attempt to catch those. Also, set the minimum value for the entire
7227 ! domain that is above the selected pressure level.
7229 DO j = jts , MIN ( jde-1 , jte )
7230 DO k = kts , kte
7231 DO i = its , MIN (ide-1 , ite )
7232 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7233 IF ( p(i,k,j) .LT. qv_max_p_safe ) THEN
7234 IF ( q(i,k,j) .GT. qv_max_flag ) THEN
7235 q(i,k,j) = qv_max_value
7236 END IF
7237 END IF
7238 IF ( p(i,k,j) .LT. qv_min_p_safe ) THEN
7239 IF ( q(i,k,j) .LT. qv_min_flag ) THEN
7240 q(i,k,j) = qv_min_value
7241 END IF
7242 END IF
7243 END DO
7244 END DO
7245 END DO
7247 END SUBROUTINE rh_to_mxrat2
7249 !---------------------------------------------------------------------
7251 SUBROUTINE rh_to_mxrat1(rh, t, p, q , wrt_liquid , &
7252 qv_max_p_safe , &
7253 qv_max_flag , qv_max_value , &
7254 qv_min_p_safe , &
7255 qv_min_flag , qv_min_value , &
7256 ids , ide , jds , jde , kds , kde , &
7257 ims , ime , jms , jme , kms , kme , &
7258 its , ite , jts , jte , kts , kte )
7260 IMPLICIT NONE
7262 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
7263 ims , ime , jms , jme , kms , kme , &
7264 its , ite , jts , jte , kts , kte
7266 LOGICAL , INTENT(IN) :: wrt_liquid
7268 REAL , INTENT(IN) :: qv_max_p_safe , qv_max_flag , qv_max_value
7269 REAL , INTENT(IN) :: qv_min_p_safe , qv_min_flag , qv_min_value
7271 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p , t
7272 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: rh
7273 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: q
7275 ! Local vars
7277 INTEGER :: i , j , k
7279 REAL :: ew , q1 , t1
7281 REAL, PARAMETER :: T_REF = 0.0
7282 REAL, PARAMETER :: MW_AIR = 28.966
7283 REAL, PARAMETER :: MW_VAP = 18.0152
7285 REAL, PARAMETER :: A0 = 6.107799961
7286 REAL, PARAMETER :: A1 = 4.436518521e-01
7287 REAL, PARAMETER :: A2 = 1.428945805e-02
7288 REAL, PARAMETER :: A3 = 2.650648471e-04
7289 REAL, PARAMETER :: A4 = 3.031240396e-06
7290 REAL, PARAMETER :: A5 = 2.034080948e-08
7291 REAL, PARAMETER :: A6 = 6.136820929e-11
7293 REAL, PARAMETER :: ES0 = 6.1121
7295 REAL, PARAMETER :: C1 = 9.09718
7296 REAL, PARAMETER :: C2 = 3.56654
7297 REAL, PARAMETER :: C3 = 0.876793
7298 REAL, PARAMETER :: EIS = 6.1071
7299 REAL :: RHS
7300 REAL, PARAMETER :: TF = 273.16
7301 REAL :: TK
7303 REAL :: ES
7304 REAL :: QS
7305 REAL, PARAMETER :: EPS = 0.622
7306 REAL, PARAMETER :: SVP1 = 0.6112
7307 REAL, PARAMETER :: SVP2 = 17.67
7308 REAL, PARAMETER :: SVP3 = 29.65
7309 REAL, PARAMETER :: SVPT0 = 273.15
7311 CHARACTER (LEN=80) :: mess
7313 ! This subroutine computes mixing ratio (q, kg/kg) from basic variables
7314 ! pressure (p, Pa), temperature (t, K) and relative humidity (rh, 1-100%).
7315 ! The reference temperature (t_ref, C) is used to describe the temperature
7316 ! at which the liquid and ice phase change occurs.
7318 DO j = jts , MIN ( jde-1 , jte )
7319 DO k = kts , kte
7320 DO i = its , MIN (ide-1 , ite )
7321 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7322 rh(i,k,j) = MIN ( MAX ( rh(i,k,j) , 0. ) , 100. )
7323 END DO
7324 END DO
7325 END DO
7327 IF ( wrt_liquid ) THEN
7328 DO j = jts , MIN ( jde-1 , jte )
7329 DO k = kts , kte
7330 DO i = its , MIN (ide-1 , ite )
7331 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7333 ! es is reduced by RH here to avoid problems in low-pressure cases
7334 if (t(i,k,j) .ne. 0.) then
7335 es=.01*rh(i,k,j)*svp1*10.*EXP(svp2*(t(i,k,j)-svpt0)/(t(i,k,j)-svp3))
7336 IF (es .ge. p(i,k,j)/100.)THEN
7337 q(i,k,j)=1.E-6
7338 WRITE(mess,*) 'Warning: vapor pressure exceeds total pressure, setting Qv to 1.E-6'
7339 CALL wrf_debug(1,mess)
7340 ELSE
7341 q(i,k,j)=MAX(eps*es/(p(i,k,j)/100.-es),1.E-6)
7342 ENDIF
7343 else
7344 q(i,k,j)=1.E-6
7345 WRITE(mess,*) 't(i,j,k) was 0 at ', i,j,k,', setting Qv to 0'
7346 CALL wrf_debug(0,mess)
7347 endif
7348 END DO
7349 END DO
7350 END DO
7352 ELSE
7353 DO j = jts , MIN ( jde-1 , jte )
7354 DO k = kts , kte
7355 DO i = its , MIN (ide-1 , ite )
7356 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7358 t1 = t(i,k,j) - 273.16
7360 ! Obviously dry.
7362 IF ( t1 .lt. -200. ) THEN
7363 q(i,k,j) = 0
7365 ELSE
7367 ! First compute the ambient vapor pressure of water
7369 ! Liquid phase t > 0 C
7371 IF ( t1 .GE. t_ref ) THEN
7372 ew = a0 + t1 * (a1 + t1 * (a2 + t1 * (a3 + t1 * (a4 + t1 * (a5 + t1 * a6)))))
7374 ! Mixed phase -47 C < t < 0 C
7376 ELSE IF ( ( t1 .LT. t_ref ) .AND. ( t1 .GE. -47. ) ) THEN
7377 ew = es0 * exp(17.67 * t1 / ( t1 + 243.5))
7379 ! Ice phase t < -47 C
7381 ELSE IF ( t1 .LT. -47. ) THEN
7382 tk = t(i,k,j)
7383 rhs = -c1 * (tf / tk - 1.) - c2 * alog10(tf / tk) + &
7384 c3 * (1. - tk / tf) + alog10(eis)
7385 ew = 10. ** rhs
7387 END IF
7389 ! Now sat vap pres obtained compute local vapor pressure
7391 ew = MAX ( ew , 0. ) * rh(i,k,j) * 0.01
7393 ! Now compute the specific humidity using the partial vapor
7394 ! pressures of water vapor (ew) and dry air (p-ew). The
7395 ! constants assume that the pressure is in hPa, so we divide
7396 ! the pressures by 100.
7398 q1 = mw_vap * ew
7399 q1 = q1 / (q1 + mw_air * (p(i,k,j)/100. - ew))
7401 q(i,k,j) = q1 / (1. - q1 )
7403 END IF
7405 END DO
7406 END DO
7407 END DO
7408 END IF
7410 ! For pressures above a defined level, reasonable Qv values should be
7411 ! a certain value or smaller. If they are larger than this, the input data
7412 ! probably had "missing" RH, and we filled in some values. This is an
7413 ! attempt to catch those. Also, set the minimum value for the entire
7414 ! domain that is above the selected pressure level.
7416 DO j = jts , MIN ( jde-1 , jte )
7417 DO k = kts , kte
7418 DO i = its , MIN (ide-1 , ite )
7419 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7420 IF ( p(i,k,j) .LT. qv_max_p_safe ) THEN
7421 IF ( q(i,k,j) .GT. qv_max_flag ) THEN
7422 q(i,k,j) = qv_max_value
7423 END IF
7424 END IF
7425 IF ( p(i,k,j) .LT. qv_min_p_safe ) THEN
7426 IF ( q(i,k,j) .LT. qv_min_flag ) THEN
7427 q(i,k,j) = qv_min_value
7428 END IF
7429 END IF
7430 END DO
7431 END DO
7432 END DO
7434 END SUBROUTINE rh_to_mxrat1
7436 !---------------------------------------------------------------------
7438 #if 0
7439 program foo
7441 ! Make this local variable have the same value as in
7442 ! frame/module_driver_constants.F: MAX_ETA
7443 integer , parameter :: max_eta = 10001
7445 INTEGER :: ids , ide , jds , jde , kds , kde , &
7446 ims , ime , jms , jme , kms , kme , &
7447 its , ite , jts , jte , kts , kte
7449 real :: max_dz = 1000
7450 real :: p_top = 100
7451 real :: g = 9.81
7452 real :: p00 = 100000
7453 real :: cvpm = -0.714285731
7454 real :: a = 50
7455 real :: r_d = 287
7456 real :: cp = 1004.5
7457 real :: t00 = 290
7458 real :: p1000mb = 100000
7459 real :: t0 = 300
7460 real :: tiso = 216.649994
7461 real :: p_strat = 5500
7462 real :: a_strat = -12
7464 real , dimension(max_eta) :: znw , eta_levels
7466 eta_levels = -1
7468 kds=1
7469 kms=1
7470 kts=1
7471 kde=70
7472 kme=70
7473 kte=70
7476 call compute_eta ( znw , auto_levels_opt, &
7477 eta_levels , max_eta , max_dz , dzbot , dzstretch_s , dzstretch_u , &
7478 p_top , g , p00 , cvpm , a , r_d , cp , &
7479 t00 , p1000mb , t0 , tiso , p_strat , a_strat , &
7480 ids , ide , jds , jde , kds , kde , &
7481 ims , ime , jms , jme , kms , kme , &
7482 its , ite , jts , jte , kts , kte )
7484 end program foo
7485 #endif
7487 SUBROUTINE compute_eta ( znw , auto_levels_opt , &
7488 eta_levels , max_eta , max_dz , dzbot , dzstretch_s , dzstretch_u , &
7489 p_top , g , p00 , cvpm , a , r_d , cp , &
7490 t00 , p1000mb , t0 , tiso , p_strat , a_strat , &
7491 ids , ide , jds , jde , kds , kde , &
7492 ims , ime , jms , jme , kms , kme , &
7493 its , ite , jts , jte , kts , kte )
7495 ! Compute eta levels, either using given values from the namelist (hardly
7496 ! a computation, yep, I know), or assuming a constant dz above the PBL,
7497 ! knowing p_top and the number of eta levels.
7499 IMPLICIT NONE
7501 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
7502 ims , ime , jms , jme , kms , kme , &
7503 its , ite , jts , jte , kts , kte
7504 REAL , INTENT(IN) :: max_dz, dzbot, dzstretch_s, dzstretch_u
7505 REAL , INTENT(IN) :: p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 , tiso
7506 REAL , INTENT(IN) :: p_strat , a_strat
7507 INTEGER , INTENT(IN) :: max_eta, auto_levels_opt
7508 REAL , DIMENSION (max_eta) :: eta_levels
7510 REAL , DIMENSION (kts:kte) , INTENT(OUT) :: znw
7512 ! Local vars
7514 INTEGER :: k , kk
7515 REAL(KIND=8) :: mub , t_init , p_surf , pb, ztop, ztop_pbl , dz , temp
7516 REAL(KIND=8) , DIMENSION(kts:kte) :: dnw
7518 INTEGER , PARAMETER :: prac_levels = 59
7519 INTEGER :: loop , loop1
7520 REAL(KIND=8) , DIMENSION(prac_levels) :: znw_prac , znu_prac , dnw_prac
7521 REAL(KIND=8) , DIMENSION(MAX(prac_levels,kde)) :: alb , phb
7522 REAL(KIND=8) :: alb_max, t_init_max, pb_max, phb_max
7523 REAL(KIND=8) :: p00_r8, t00_r8, a_r8, tiso_r8
7525 CHARACTER(LEN=256) :: message
7527 ! Gee, do the eta levels come in from the namelist?
7529 IF ( ABS(eta_levels(1)+1.) .GT. 0.0000001 ) THEN
7531 ! Check to see if the array is oriented OK, we can easily fix an upside down oops.
7533 IF ( ( ABS(eta_levels(1 )-1.) .LT. 0.0000001 ) .AND. &
7534 ( ABS(eta_levels(kde)-0.) .LT. 0.0000001 ) ) THEN
7535 DO k = kds+1 , kde-1
7536 znw(k) = eta_levels(k)
7537 END DO
7538 znw( 1) = 1.
7539 znw(kde) = 0.
7540 ELSE IF ( ( ABS(eta_levels(kde)-1.) .LT. 0.0000001 ) .AND. &
7541 ( ABS(eta_levels(1 )-0.) .LT. 0.0000001 ) ) THEN
7542 DO k = kds+1 , kde-1
7543 znw(k) = eta_levels(kde+1-k)
7544 END DO
7545 znw( 1) = 1.
7546 znw(kde) = 0.
7547 ELSE
7548 CALL wrf_error_fatal ( 'First eta level should be 1.0 and the last 0.0 in namelist' )
7549 END IF
7551 ! Check to see if the input full-level eta array is monotonic.
7553 DO k = kds , kde-1
7554 IF ( znw(k) .LE. znw(k+1) ) THEN
7555 PRINT *,'eta on full levels is not monotonic'
7556 PRINT *,'eta (',k,') = ',znw(k)
7557 PRINT *,'eta (',k+1,') = ',znw(k+1)
7558 CALL wrf_error_fatal ( 'Fix non-monotonic "eta_levels" in the namelist.input file' )
7559 END IF
7560 END DO
7562 ! Compute eta levels assuming a constant delta z above the PBL.
7564 ELSE
7565 IF( auto_levels_opt == 1 ) THEN
7566 print *,'using old automatic levels program'
7567 ! Compute top of the atmosphere with some silly levels. We just want to
7568 ! integrate to get a reasonable value for ztop. We use the planned PBL-esque
7569 ! levels, and then just coarse resolution above that. We know p_top, and we
7570 ! have the base state vars.
7572 p_surf = p00
7574 znw_prac = (/ 1.0000_8 , 0.9930_8 , 0.9830_8 , 0.9700_8 , 0.9540_8 , 0.9340_8 , 0.9090_8 , 0.8800_8 , &
7575 0.8500_8 , 0.8000_8 , 0.7500_8 , 0.7000_8 , 0.6500_8 , 0.6000_8 , 0.5500_8 , 0.5000_8 , &
7576 0.4500_8 , 0.4000_8 , 0.3500_8 , 0.3000_8 , 0.2500_8 , 0.2000_8 , 0.1500_8 , 0.1000_8 , &
7577 0.0800_8 , 0.0600_8 , 0.0400_8 , 0.0200_8 , &
7578 0.0150_8 , 0.0100_8 , 0.0090_8 , 0.0080_8 , 0.0070_8 , 0.0060_8 , 0.0050_8 , 0.0040_8 , &
7579 0.0035_8 , 0.0030_8 , &
7580 0.0028_8 , 0.0026_8 , 0.0024_8 , 0.0022_8 , 0.0020_8 , &
7581 0.0018_8 , 0.0016_8 , 0.0014_8 , 0.0012_8 , 0.0010_8 , &
7582 0.0009_8 , 0.0008_8 , 0.0007_8 , 0.0006_8 , 0.0005_8 , 0.0004_8 , 0.0003_8 , &
7583 0.0002_8 , 0.0001_8 , 0.00005_8, 0.0000_8 /)
7585 DO k = 1 , prac_levels - 1
7586 znu_prac(k) = ( znw_prac(k) + znw_prac(k+1) ) * 0.5_8
7587 dnw_prac(k) = znw_prac(k+1) - znw_prac(k)
7588 END DO
7590 tiso_r8 = tiso
7591 t00_r8 = t00
7592 a_r8 = a
7593 p00_r8 = p00
7594 DO k = 1, prac_levels-1
7595 pb = znu_prac(k)*(p_surf - p_top) + p_top
7596 temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7597 IF ( pb .LT. p_strat ) THEN
7598 temp = tiso + A_strat*LOG(pb/p_strat)
7599 END IF
7600 t_init = temp*(p00/pb)**(r_d/cp) - t0
7601 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7602 END DO
7604 ! Base state mu is defined as base state surface pressure minus p_top
7606 mub = p_surf - p_top
7608 ! Integrate base geopotential, starting at terrain elevation.
7610 phb(1) = 0._8
7611 DO k = 2,prac_levels
7612 phb(k) = phb(k-1) - dnw_prac(k-1)*mub*alb(k-1)
7613 END DO
7615 ! So, now we know the model top in meters. Get the average depth above the PBL
7616 ! of each of the remaining levels. We are going for a constant delta z thickness.
7618 ztop = phb(prac_levels) / g
7619 ztop_pbl = phb(8 ) / g
7620 dz = ( ztop - ztop_pbl ) / REAL ( kde - 8 )
7622 IF ( dz .GE. max_dz ) THEN
7623 WRITE (message,FMT='("With a requested ",F7.1," Pa model top, the model lid will be about ",F7.1," m.")') p_top, ztop
7624 CALL wrf_message ( message )
7625 WRITE (message,FMT='("With ",I3," levels above the PBL, the level thickness will be about ",F6.1," m.")') kde-8, dz
7626 CALL wrf_message ( message )
7627 WRITE (message,FMT='("Thicknesses greater than ",F7.1," m are not recommended.")') max_dz
7628 CALL wrf_message ( message )
7629 CALL wrf_error_fatal ( 'Add more levels to namelist.input for e_vert' )
7630 END IF
7632 ! Standard levels near the surface so no one gets in trouble.
7634 DO k = 1 , 8
7635 eta_levels(k) = znw_prac(k)
7636 END DO
7638 ! Using d phb(k)/ d eta(k) = -mub * alb(k), eqn 2.9
7639 ! Skamarock et al, NCAR TN 468. Use full levels, so
7640 ! use twice the thickness.
7642 DO k = 8, kte-1-2
7644 find_prac : DO kk = 1 , prac_levels
7645 IF (znw_prac(kk) .LT. eta_levels(k) ) THEN
7646 EXIT find_prac
7647 END IF
7648 end do find_prac
7650 pb = 0.5*(eta_levels(k)+znw_prac(kk)) * (p_surf - p_top) + p_top
7652 temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7653 IF ( pb .LT. p_strat ) THEN
7654 temp = tiso + A_strat * LOG ( pb/p_strat )
7655 END IF
7656 ! temp = t00 + A*LOG(pb/p00)
7657 t_init = temp*(p00/pb)**(r_d/cp) - t0
7658 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7659 eta_levels(k+1) = eta_levels(k) - dz*g / ( mub*alb(k) )
7660 pb = 0.5*(eta_levels(k)+eta_levels(k+1)) * (p_surf - p_top) + p_top
7662 temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7663 IF ( pb .LT. p_strat ) THEN
7664 temp = tiso + A_strat * LOG ( pb/p_strat )
7665 END IF
7666 ! temp = t00 + A*LOG(pb/p00)
7667 t_init = temp*(p00/pb)**(r_d/cp) - t0
7668 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7669 eta_levels(k+1) = eta_levels(k) - dz*g / ( mub*alb(k) )
7670 pb = 0.5*(eta_levels(k)+eta_levels(k+1)) * (p_surf - p_top) + p_top
7672 phb(k+1) = phb(k) - (eta_levels(k+1)-eta_levels(k)) * mub*alb(k)
7673 END DO
7675 alb_max = alb(kte-1-2)
7676 t_init_max = t_init
7677 pb_max = pb
7678 phb_max = phb(kte-1)
7680 DO k = 1 , kte-1-2
7681 znw(k) = eta_levels(k)
7682 END DO
7683 znw(kte-2) = 0.000
7685 ! There is some iteration. We want the top level, ztop, to be
7686 ! consistent with the delta z, and we want the half level values
7687 ! to be consistent with the eta levels. The inner loop to 10 gets
7688 ! the eta levels very accurately, but has a residual at the top, due
7689 ! to dz changing. We reset dz five times, and then things seem OK.
7691 DO loop1 = 1 , 5
7692 DO loop = 1 , 10
7693 DO k = 8, kte-1-2-1
7694 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top
7695 temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7696 IF ( pb .LT. p_strat ) THEN
7697 temp = tiso + A_strat * LOG ( pb/p_strat )
7698 END IF
7699 t_init = temp*(p00/pb)**(r_d/cp) - t0
7700 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7701 znw(k+1) = znw(k) - dz*g / ( mub*alb(k) )
7702 END DO
7703 pb = pb_max
7704 t_init = t_init_max
7705 alb(kte-1-2) = alb_max
7706 znw(kte-2) = znw(kte-1-2) - dz*g / ( mub*alb(kte-1-2) )
7707 IF ( ( loop1 .EQ. 5 ) .AND. ( loop .EQ. 10 ) ) THEN
7708 print *,'Converged znw(kte) should be about 0.0 = ',znw(kte-2)
7709 END IF
7710 znw(kte-2) = 0.000
7711 END DO
7713 ! Here is where we check the eta levels values we just computed.
7715 DO k = 1, kde-1-2
7716 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top
7717 temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7718 IF ( pb .LT. p_strat ) THEN
7719 temp = tiso + A_strat * LOG ( pb/p_strat )
7720 END IF
7721 t_init = temp*(p00/pb)**(r_d/cp) - t0
7722 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7723 END DO
7725 phb(1) = 0.
7726 DO k = 2,kde-2
7727 phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1)
7728 END DO
7730 ! Reset the model top and the dz, and iterate.
7732 ztop = phb(kde-2)/g
7733 ztop_pbl = phb(8)/g
7734 dz = ( ztop - ztop_pbl ) / REAL ( (kde-2) - 8 )
7735 END DO
7737 IF ( dz .GT. max_dz ) THEN
7738 print *,'z (m) = ',phb(1)/g
7739 do k = 2 ,kte-2
7740 print *,'z (m) and dz (m) = ',phb(k)/g,(phb(k)-phb(k-1))/g
7741 end do
7742 print *,'dz (m) above fixed eta levels = ',dz
7743 print *,'namelist max_dz (m) = ',max_dz
7744 print *,'namelist p_top (Pa) = ',p_top
7745 CALL wrf_debug ( 0, 'You need one of three things:' )
7746 CALL wrf_debug ( 0, '1) More eta levels to reduce the dz: e_vert' )
7747 CALL wrf_debug ( 0, '2) A lower p_top so your total height is reduced: p_top_requested')
7748 CALL wrf_debug ( 0, '3) Increase the maximum allowable eta thickness: max_dz')
7749 CALL wrf_debug ( 0, 'All are namelist options')
7750 CALL wrf_error_fatal ( 'dz above fixed eta levels is too large')
7751 END IF
7753 ! Add those 2 levels back into the middle, just above the 8 levels
7754 ! that semi define a boundary layer. After we open up the levels,
7755 ! then we just linearly interpolate in znw. So now levels 1-8 are
7756 ! specified as the fixed boundary layer levels given in this routine.
7757 ! The top levels, 12 through kte are those computed. The middle
7758 ! levels 9, 10, and 11 are equi-spaced in znw, and are each 1/2 the
7759 ! the znw thickness of levels 11 through 12.
7761 DO k = kte-2 , 9 , -1
7762 znw(k+2) = znw(k)
7763 END DO
7765 znw( 9) = 0.75 * znw( 8) + 0.25 * znw(12)
7766 znw(10) = 0.50 * znw( 8) + 0.50 * znw(12)
7767 znw(11) = 0.25 * znw( 8) + 0.75 * znw(12)
7769 DO k = 8, kte-1
7770 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top
7771 temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7772 IF ( pb .LT. p_strat ) THEN
7773 temp = tiso + A_strat * LOG ( pb/p_strat )
7774 END IF
7775 t_init = temp*(p00/pb)**(r_d/cp) - t0
7776 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7777 phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1)
7778 END DO
7779 phb(kte) = phb(kte-1) - (znw(kte)-znw(kte-1)) * mub*alb(kte-1)
7781 ELSE IF (auto_levels_opt == 2) THEN
7782 print *,'using new automatic levels program'
7783 CALL levels(kte-1, p_top, znw, max_dz, dzbot, dzstretch_s, dzstretch_u, r_d, g )
7784 p_surf = p00
7785 tiso_r8 = tiso
7786 t00_r8 = t00
7787 a_r8 = a
7788 p00_r8 = p00
7789 mub = p_surf - p_top
7790 phb(1) = 0.
7791 DO k = 1, kte-1
7792 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top
7793 temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) )
7794 IF ( pb .LT. p_strat ) THEN
7795 temp = tiso + A_strat * LOG ( pb/p_strat )
7796 END IF
7797 t_init = temp*(p00/pb)**(r_d/cp) - t0
7798 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm
7799 phb(k+1) = phb(k) - (znw(k+1)-znw(k)) * mub*alb(k)
7800 END DO
7801 ELSE
7802 print *,'auto_levels_opt=',auto_levels_opt
7803 CALL wrf_error_fatal ( 'auto_levels_opt needs to be 1 or 2')
7804 ENDIF
7805 k=1
7806 WRITE (*,FMT='("Full level index = ",I4," Height = ",F7.1," m")') k,phb(1)/g
7807 do k = 2 ,kte
7808 WRITE (*,FMT='("Full level index = ",I4," Height = ",F7.1," m Thickness = ",F6.1," m")') k,phb(k)/g,(phb(k)-phb(k-1))/g
7809 end do
7811 END IF
7813 END SUBROUTINE compute_eta
7815 !---------------------------------------------------------------------
7816 SUBROUTINE levels ( nlev, ptop, eta, dzmax, dzbot, dzstretch_s, dzstretch_u, r_d, g )
7817 implicit none
7818 integer, intent(in) :: nlev
7819 real, intent(in) :: ptop, dzmax, dzbot, dzstretch_s, dzstretch_u, r_d, g
7820 real, dimension(0:nlev), intent(out) :: eta
7822 real, dimension(nlev) :: zup, pup
7823 real :: tt, a
7824 real :: ztop, dz, dztest, zscale
7825 integer :: isave, i
7827 tt=290. ! isothermal temperature used for z/log p relation - tt=290 fits dzbot
7828 ztop=r_d*tt/g*alog(1.e5/ptop)
7829 zscale=r_d*tt/g
7830 dz=dzbot
7831 zup(1)=dz
7832 pup(1)=1.e5*exp(-g*zup(1)/r_d/tt)
7833 eta(0)=1.0
7834 eta(1)=(pup(1)-ptop)/(1.e5-ptop)
7835 print *,1,dz,zup(1),eta(1)
7836 isave=1
7837 do i=1,nlev-1
7838 a=dzstretch_u+(dzstretch_s-dzstretch_u)*max((dzmax*0.5-dz)/(dzmax*0.5), 0.)
7839 dz=a*dz
7840 dztest=(ztop-zup(isave))/(nlev-isave)
7841 if(dztest.lt.dz)exit
7842 isave=i+1
7843 zup(i+1)=zup(i)+dz
7844 pup(i+1)=1.e5*exp(-g*zup(i+1)/r_d/tt)
7845 eta(i+1)=(pup(i+1)-ptop)/(1.e5-ptop)
7846 print *,i+1,dz,zup(i+1),eta(i+1),a
7847 IF ( i .EQ. nlev-1 ) THEN
7848 CALL wrf_debug ( 0, 'You need one of four things:' )
7849 CALL wrf_debug ( 0, '1) More eta levels: e_vert' )
7850 CALL wrf_debug ( 0, '2) A lower p_top: p_top_requested')
7851 CALL wrf_debug ( 0, '3) Increase the lowest eta thickness: dzbot')
7852 CALL wrf_debug ( 0, '4) Increase the stretching factor: dzstretch_s or dzstretch_u')
7853 CALL wrf_debug ( 0, 'All are namelist options')
7854 CALL wrf_error_fatal ( 'not enough eta levels to reach p_top')
7855 END IF
7856 enddo
7857 print *,ztop,zup(isave),nlev,isave
7858 dz=(ztop-zup(isave))/(nlev-isave)
7859 IF ( dz .GT. 1.5*dzmax ) THEN ! isothermal temp 1.5 times stratosphere temp
7860 CALL wrf_debug ( 0, 'Warning: Upper levels may be too thick' )
7861 CALL wrf_debug ( 0, 'You need one of five things:' )
7862 CALL wrf_debug ( 0, '1) More eta levels: e_vert' )
7863 CALL wrf_debug ( 0, '2) A lower p_top: p_top_requested')
7864 CALL wrf_debug ( 0, '3) Increase the lowest eta thickness: dzbot')
7865 CALL wrf_debug ( 0, '4) Increase the stretching factor: dzstretch_s or dzstretch_u')
7866 CALL wrf_debug ( 0, '5) Increase the maximum allowed thickness: max_dz')
7867 CALL wrf_debug ( 0, 'All are namelist options')
7868 CALL wrf_error_fatal ( 'Upper levels may be too thick')
7869 END IF
7870 do i=isave,nlev-1
7871 zup(i+1)=zup(i)+dz
7872 pup(i+1)=1.e5*exp(-g*zup(i+1)/r_d/tt)
7873 eta(i+1)=(pup(i+1)-ptop)/(1.e5-ptop)
7874 print *,i+1,dz,zup(i+1),eta(i+1)
7875 enddo
7876 eta(nlev) = 0.
7877 print 1000, eta
7878 1000 format(10f10.4)
7879 !1000 format(10g10.3)
7880 return
7881 END SUBROUTINE levels
7883 !---------------------------------------------------------------------
7885 SUBROUTINE monthly_min_max ( field_in , field_min , field_max , &
7886 ids , ide , jds , jde , kds , kde , &
7887 ims , ime , jms , jme , kms , kme , &
7888 its , ite , jts , jte , kts , kte )
7890 ! Plow through each month, find the max, min values for each i,j.
7892 IMPLICIT NONE
7894 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
7895 ims , ime , jms , jme , kms , kme , &
7896 its , ite , jts , jte , kts , kte
7898 REAL , DIMENSION(ims:ime,12,jms:jme) , INTENT(IN) :: field_in
7899 REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_min , field_max
7901 ! Local vars
7903 INTEGER :: i , j , l
7904 REAL :: minner , maxxer
7906 DO j = jts , MIN(jde-1,jte)
7907 DO i = its , MIN(ide-1,ite)
7908 minner = field_in(i,1,j)
7909 maxxer = field_in(i,1,j)
7910 DO l = 2 , 12
7911 IF ( field_in(i,l,j) .LT. minner ) THEN
7912 minner = field_in(i,l,j)
7913 END IF
7914 IF ( field_in(i,l,j) .GT. maxxer ) THEN
7915 maxxer = field_in(i,l,j)
7916 END IF
7917 END DO
7918 field_min(i,j) = minner
7919 field_max(i,j) = maxxer
7920 END DO
7921 END DO
7923 END SUBROUTINE monthly_min_max
7925 !---------------------------------------------------------------------
7927 SUBROUTINE monthly_interp_to_date ( field_in , date_str , field_out , &
7928 ids , ide , jds , jde , kds , kde , &
7929 ims , ime , jms , jme , kms , kme , &
7930 its , ite , jts , jte , kts , kte )
7932 ! Linrarly in time interpolate data to a current valid time. The data is
7933 ! assumed to come in "monthly", valid at the 15th of every month.
7935 IMPLICIT NONE
7937 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
7938 ims , ime , jms , jme , kms , kme , &
7939 its , ite , jts , jte , kts , kte
7941 CHARACTER (LEN=24) , INTENT(IN) :: date_str
7942 REAL , DIMENSION(ims:ime,12,jms:jme) , INTENT(IN) :: field_in
7943 REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_out
7945 ! Local vars
7947 INTEGER :: i , j , l
7948 INTEGER , DIMENSION(0:13) :: middle
7949 INTEGER :: target_julyr , target_julday , target_date
7950 INTEGER :: julyr , julday , int_month , month1 , month2
7951 REAL :: gmt
7952 CHARACTER (LEN=4) :: yr
7953 CHARACTER (LEN=2) :: mon , day15
7956 WRITE(day15,FMT='(I2.2)') 15
7957 DO l = 1 , 12
7958 WRITE(mon,FMT='(I2.2)') l
7959 CALL get_julgmt ( date_str(1:4)//'-'//mon//'-'//day15//'_'//'00:00:00.0000' , julyr , julday , gmt )
7960 middle(l) = julyr*1000 + julday
7961 END DO
7963 l = 0
7964 middle(l) = middle( 1) - 31
7966 l = 13
7967 middle(l) = middle(12) + 31
7969 CALL get_julgmt ( date_str , target_julyr , target_julday , gmt )
7970 target_date = target_julyr * 1000 + target_julday
7971 find_month : DO l = 0 , 12
7972 IF ( ( middle(l) .LT. target_date ) .AND. ( middle(l+1) .GE. target_date ) ) THEN
7973 DO j = jts , MIN ( jde-1 , jte )
7974 DO i = its , MIN (ide-1 , ite )
7975 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
7976 int_month = l
7977 IF ( ( int_month .EQ. 0 ) .OR. ( int_month .EQ. 12 ) ) THEN
7978 month1 = 12
7979 month2 = 1
7980 ELSE
7981 month1 = int_month
7982 month2 = month1 + 1
7983 END IF
7984 field_out(i,j) = ( field_in(i,month2,j) * ( target_date - middle(l) ) + &
7985 field_in(i,month1,j) * ( middle(l+1) - target_date ) ) / &
7986 ( middle(l+1) - middle(l) )
7987 END DO
7988 END DO
7989 EXIT find_month
7990 END IF
7991 END DO find_month
7993 END SUBROUTINE monthly_interp_to_date
7995 !---------------------------------------------------------------------
7997 SUBROUTINE eightday_selector ( field_in , date_str , field_out , &
7998 ids , ide , jds , jde , kds , kde , &
7999 ims , ime , jms , jme , kms , kme , &
8000 its , ite , jts , jte , kts , kte )
8002 ! Given current date, select time-matching monthly entry from grid.
8003 ! No interpolation.
8005 IMPLICIT NONE
8007 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
8008 ims , ime , jms , jme , kms , kme , &
8009 its , ite , jts , jte , kts , kte
8011 CHARACTER (LEN=24) , INTENT(IN) :: date_str
8012 REAL , DIMENSION(ims:ime,46,jms:jme) , INTENT(IN) :: field_in !46
8013 REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_out
8015 ! Local vars
8017 INTEGER :: i , j
8018 INTEGER :: julyr, julday, eightday
8019 REAL :: gmt
8021 CALL get_julgmt ( date_str , julyr , julday , gmt )
8022 eightday = ((julday-1) / 8) + 1
8023 ! print *, 'date_str: ', date_str
8024 ! print *, 'julyr, julday: ', julyr, julday
8025 ! print *, 'eightday: ', eightday
8027 DO j = jts , MIN ( jde-1 , jte )
8028 DO i = its , MIN (ide-1 , ite )
8029 field_out(i,j) = field_in(i,eightday,j)
8030 END DO
8031 END DO
8033 END SUBROUTINE eightday_selector
8035 !---------------------------------------------------------------------
8037 SUBROUTINE sfcprs (t, q, height, pslv, ter, avgsfct, p, &
8038 psfc, ez_method, &
8039 ids , ide , jds , jde , kds , kde , &
8040 ims , ime , jms , jme , kms , kme , &
8041 its , ite , jts , jte , kts , kte )
8044 ! Computes the surface pressure using the input height,
8045 ! temperature and q (already computed from relative
8046 ! humidity) on p surfaces. Sea level pressure is used
8047 ! to extrapolate a first guess.
8049 IMPLICIT NONE
8051 REAL, PARAMETER :: gamma = 6.5E-3
8052 REAL, PARAMETER :: pconst = 10000.0
8053 REAL, PARAMETER :: Rd = r_d
8054 REAL, PARAMETER :: TC = svpt0 + 17.5
8056 REAL, PARAMETER :: gammarg = gamma * Rd / g
8057 REAL, PARAMETER :: rov2 = Rd / 2.
8059 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
8060 ims , ime , jms , jme , kms , kme , &
8061 its , ite , jts , jte , kts , kte
8062 LOGICAL , INTENT ( IN ) :: ez_method
8064 REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: t, q, height, p
8065 REAL , DIMENSION (ims:ime, jms:jme) , INTENT(IN ):: pslv , ter, avgsfct
8066 REAL , DIMENSION (ims:ime, jms:jme) , INTENT(OUT):: psfc
8068 INTEGER :: i
8069 INTEGER :: j
8070 INTEGER :: k
8071 INTEGER , DIMENSION (its:ite,jts:jte) :: k500 , k700 , k850
8073 LOGICAL :: l1
8074 LOGICAL :: l2
8075 LOGICAL :: l3
8076 LOGICAL :: OK
8078 REAL :: gamma78 ( its:ite,jts:jte )
8079 REAL :: gamma57 ( its:ite,jts:jte )
8080 REAL :: ht ( its:ite,jts:jte )
8081 REAL :: p1 ( its:ite,jts:jte )
8082 REAL :: t1 ( its:ite,jts:jte )
8083 REAL :: t500 ( its:ite,jts:jte )
8084 REAL :: t700 ( its:ite,jts:jte )
8085 REAL :: t850 ( its:ite,jts:jte )
8086 REAL :: tfixed ( its:ite,jts:jte )
8087 REAL :: tsfc ( its:ite,jts:jte )
8088 REAL :: tslv ( its:ite,jts:jte )
8090 ! We either compute the surface pressure from a time averaged surface temperature
8091 ! (what we will call the "easy way"), or we try to remove the diurnal impact on the
8092 ! surface temperature (what we will call the "other way"). Both are essentially
8093 ! corrections to a sea level pressure with a high-resolution topography field.
8095 IF ( ez_method ) THEN
8097 DO j = jts , MIN(jde-1,jte)
8098 DO i = its , MIN(ide-1,ite)
8099 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8100 psfc(i,j) = pslv(i,j) * ( 1.0 + gamma * ter(i,j) / avgsfct(i,j) ) ** ( - g / ( Rd * gamma ) )
8101 END DO
8102 END DO
8104 ELSE
8106 ! Find the locations of the 850, 700 and 500 mb levels.
8108 k850 = 0 ! find k at: P=850
8109 k700 = 0 ! P=700
8110 k500 = 0 ! P=500
8112 i = its
8113 j = jts
8114 DO k = kts+1 , kte
8115 IF (NINT(p(i,k,j)) .EQ. 85000) THEN
8116 k850(i,j) = k
8117 ELSE IF (NINT(p(i,k,j)) .EQ. 70000) THEN
8118 k700(i,j) = k
8119 ELSE IF (NINT(p(i,k,j)) .EQ. 50000) THEN
8120 k500(i,j) = k
8121 END IF
8122 END DO
8124 IF ( ( k850(i,j) .EQ. 0 ) .OR. ( k700(i,j) .EQ. 0 ) .OR. ( k500(i,j) .EQ. 0 ) ) THEN
8126 DO j = jts , MIN(jde-1,jte)
8127 DO i = its , MIN(ide-1,ite)
8128 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8129 psfc(i,j) = pslv(i,j) * ( 1.0 + gamma * ter(i,j) / t(i,1,j) ) ** ( - g / ( Rd * gamma ) )
8130 END DO
8131 END DO
8133 RETURN
8134 #if 0
8136 ! Possibly it is just that we have a generalized vertical coord, so we do not
8137 ! have the values exactly. Do a simple assignment to a close vertical level.
8139 DO j = jts , MIN(jde-1,jte)
8140 DO i = its , MIN(ide-1,ite)
8141 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8142 DO k = kts+1 , kte-1
8143 IF ( ( p(i,k,j) - 85000. ) * ( p(i,k+1,j) - 85000. ) .LE. 0.0 ) THEN
8144 k850(i,j) = k
8145 END IF
8146 IF ( ( p(i,k,j) - 70000. ) * ( p(i,k+1,j) - 70000. ) .LE. 0.0 ) THEN
8147 k700(i,j) = k
8148 END IF
8149 IF ( ( p(i,k,j) - 50000. ) * ( p(i,k+1,j) - 50000. ) .LE. 0.0 ) THEN
8150 k500(i,j) = k
8151 END IF
8152 END DO
8153 END DO
8154 END DO
8156 ! If we *still* do not have the k levels, punt. I mean, we did try.
8158 OK = .TRUE.
8159 DO j = jts , MIN(jde-1,jte)
8160 DO i = its , MIN(ide-1,ite)
8161 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8162 IF ( ( k850(i,j) .EQ. 0 ) .OR. ( k700(i,j) .EQ. 0 ) .OR. ( k500(i,j) .EQ. 0 ) ) THEN
8163 OK = .FALSE.
8164 PRINT '(A)','(i,j) = ',i,j,' Error in finding p level for 850, 700 or 500 hPa.'
8165 DO K = kts+1 , kte
8166 PRINT '(A,I3,A,F10.2,A)','K = ',k,' PRESSURE = ',p(i,k,j),' Pa'
8167 END DO
8168 PRINT '(A)','Expected 850, 700, and 500 mb values, at least.'
8169 END IF
8170 END DO
8171 END DO
8172 IF ( .NOT. OK ) THEN
8173 CALL wrf_error_fatal ( 'wrong pressure levels' )
8174 END IF
8175 #endif
8177 ! We are here if the data is isobaric and we found the levels for 850, 700,
8178 ! and 500 mb right off the bat.
8180 ELSE
8181 DO j = jts , MIN(jde-1,jte)
8182 DO i = its , MIN(ide-1,ite)
8183 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8184 k850(i,j) = k850(its,jts)
8185 k700(i,j) = k700(its,jts)
8186 k500(i,j) = k500(its,jts)
8187 END DO
8188 END DO
8189 END IF
8191 ! The 850 hPa level of geopotential height is called something special.
8193 DO j = jts , MIN(jde-1,jte)
8194 DO i = its , MIN(ide-1,ite)
8195 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8196 ht(i,j) = height(i,k850(i,j),j)
8197 END DO
8198 END DO
8200 ! The variable ht is now -ter/ht(850 hPa). The plot thickens.
8202 DO j = jts , MIN(jde-1,jte)
8203 DO i = its , MIN(ide-1,ite)
8204 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8205 ht(i,j) = -ter(i,j) / ht(i,j)
8206 END DO
8207 END DO
8209 ! Make an isothermal assumption to get a first guess at the surface
8210 ! pressure. This is to tell us which levels to use for the lapse
8211 ! rates in a bit.
8213 DO j = jts , MIN(jde-1,jte)
8214 DO i = its , MIN(ide-1,ite)
8215 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8216 psfc(i,j) = pslv(i,j) * (pslv(i,j) / p(i,k850(i,j),j)) ** ht(i,j)
8217 END DO
8218 END DO
8220 ! Get a pressure more than pconst Pa above the surface - p1. The
8221 ! p1 is the top of the level that we will use for our lapse rate
8222 ! computations.
8224 DO j = jts , MIN(jde-1,jte)
8225 DO i = its , MIN(ide-1,ite)
8226 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8227 IF ( ( psfc(i,j) - 95000. ) .GE. 0. ) THEN
8228 p1(i,j) = 85000.
8229 ELSE IF ( ( psfc(i,j) - 70000. ) .GE. 0. ) THEN
8230 p1(i,j) = psfc(i,j) - pconst
8231 ELSE
8232 p1(i,j) = 50000.
8233 END IF
8234 END DO
8235 END DO
8237 ! Compute virtual temperatures for k850, k700, and k500 layers. Now
8238 ! you see why we wanted Q on pressure levels, it all is beginning
8239 ! to make sense.
8241 DO j = jts , MIN(jde-1,jte)
8242 DO i = its , MIN(ide-1,ite)
8243 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8244 t850(i,j) = t(i,k850(i,j),j) * (1. + 0.608 * q(i,k850(i,j),j))
8245 t700(i,j) = t(i,k700(i,j),j) * (1. + 0.608 * q(i,k700(i,j),j))
8246 t500(i,j) = t(i,k500(i,j),j) * (1. + 0.608 * q(i,k500(i,j),j))
8247 END DO
8248 END DO
8250 ! Compute lapse rates between these three levels. These are
8251 ! environmental values for each (i,j).
8253 DO j = jts , MIN(jde-1,jte)
8254 DO i = its , MIN(ide-1,ite)
8255 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8256 gamma78(i,j) = ALOG(t850(i,j) / t700(i,j)) / ALOG (p(i,k850(i,j),j) / p(i,k700(i,j),j) )
8257 gamma57(i,j) = ALOG(t700(i,j) / t500(i,j)) / ALOG (p(i,k700(i,j),j) / p(i,k500(i,j),j) )
8258 END DO
8259 END DO
8261 DO j = jts , MIN(jde-1,jte)
8262 DO i = its , MIN(ide-1,ite)
8263 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8264 IF ( ( psfc(i,j) - 95000. ) .GE. 0. ) THEN
8265 t1(i,j) = t850(i,j)
8266 ELSE IF ( ( psfc(i,j) - 85000. ) .GE. 0. ) THEN
8267 t1(i,j) = t700(i,j) * (p1(i,j) / (p(i,k700(i,j),j))) ** gamma78(i,j)
8268 ELSE IF ( ( psfc(i,j) - 70000. ) .GE. 0.) THEN
8269 t1(i,j) = t500(i,j) * (p1(i,j) / (p(i,k500(i,j),j))) ** gamma57(i,j)
8270 ELSE
8271 t1(i,j) = t500(i,j)
8272 ENDIF
8273 END DO
8274 END DO
8276 ! From our temperature way up in the air, we extrapolate down to
8277 ! the sea level to get a guess at the sea level temperature.
8279 DO j = jts , MIN(jde-1,jte)
8280 DO i = its , MIN(ide-1,ite)
8281 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8282 tslv(i,j) = t1(i,j) * (pslv(i,j) / p1(i,j)) ** gammarg
8283 END DO
8284 END DO
8286 ! The new surface temperature is computed from the with new sea level
8287 ! temperature, just using the elevation and a lapse rate. This lapse
8288 ! rate is -6.5 K/km.
8290 DO j = jts , MIN(jde-1,jte)
8291 DO i = its , MIN(ide-1,ite)
8292 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8293 tsfc(i,j) = tslv(i,j) - gamma * ter(i,j)
8294 END DO
8295 END DO
8297 ! A small correction to the sea-level temperature, in case it is too warm.
8299 DO j = jts , MIN(jde-1,jte)
8300 DO i = its , MIN(ide-1,ite)
8301 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8302 tfixed(i,j) = tc - 0.005 * (tsfc(i,j) - tc) ** 2
8303 END DO
8304 END DO
8306 DO j = jts , MIN(jde-1,jte)
8307 DO i = its , MIN(ide-1,ite)
8308 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8309 l1 = tslv(i,j) .LT. tc
8310 l2 = tsfc(i,j) .LE. tc
8311 l3 = .NOT. l1
8312 IF ( l2 .AND. l3 ) THEN
8313 tslv(i,j) = tc
8314 ELSE IF ( ( .NOT. l2 ) .AND. l3 ) THEN
8315 tslv(i,j) = tfixed(i,j)
8316 END IF
8317 END DO
8318 END DO
8320 ! Finally, we can get to the surface pressure.
8322 DO j = jts , MIN(jde-1,jte)
8323 DO i = its , MIN(ide-1,ite)
8324 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8325 p1(i,j) = - ter(i,j) * g / ( rov2 * ( tsfc(i,j) + tslv(i,j) ) )
8326 psfc(i,j) = pslv(i,j) * EXP ( p1(i,j) )
8327 END DO
8328 END DO
8330 END IF
8332 ! Surface pressure and sea-level pressure are the same at sea level.
8334 ! DO j = jts , MIN(jde-1,jte)
8335 ! DO i = its , MIN(ide-1,ite)
8336 ! IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8337 ! IF ( ABS ( ter(i,j) ) .LT. 0.1 ) THEN
8338 ! psfc(i,j) = pslv(i,j)
8339 ! END IF
8340 ! END DO
8341 ! END DO
8343 END SUBROUTINE sfcprs
8345 !---------------------------------------------------------------------
8347 SUBROUTINE sfcprs2(t, q, height, psfc_in, ter, avgsfct, p, &
8348 psfc, ez_method, &
8349 ids , ide , jds , jde , kds , kde , &
8350 ims , ime , jms , jme , kms , kme , &
8351 its , ite , jts , jte , kts , kte )
8354 ! Computes the surface pressure using the input height,
8355 ! temperature and q (already computed from relative
8356 ! humidity) on p surfaces. Sea level pressure is used
8357 ! to extrapolate a first guess.
8359 IMPLICIT NONE
8361 REAL, PARAMETER :: Rd = r_d
8363 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
8364 ims , ime , jms , jme , kms , kme , &
8365 its , ite , jts , jte , kts , kte
8366 LOGICAL , INTENT ( IN ) :: ez_method
8368 REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: t, q, height, p
8369 REAL , DIMENSION (ims:ime, jms:jme) , INTENT(IN ):: psfc_in , ter, avgsfct
8370 REAL , DIMENSION (ims:ime, jms:jme) , INTENT(OUT):: psfc
8372 INTEGER :: i
8373 INTEGER :: j
8374 INTEGER :: k
8376 REAL :: tv_sfc_avg , tv_sfc , del_z
8378 ! Compute the new surface pressure from the old surface pressure, and a
8379 ! known change in elevation at the surface.
8381 ! del_z = diff in surface topo, lo-res vs hi-res
8382 ! psfc = psfc_in * exp ( g del_z / (Rd Tv_sfc ) )
8385 IF ( ez_method ) THEN
8386 DO j = jts , MIN(jde-1,jte)
8387 DO i = its , MIN(ide-1,ite)
8388 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8389 tv_sfc_avg = avgsfct(i,j) * (1. + 0.608 * q(i,1,j))
8390 del_z = height(i,1,j) - ter(i,j)
8391 psfc(i,j) = psfc_in(i,j) * EXP ( g * del_z / ( Rd * tv_sfc_avg ) )
8392 END DO
8393 END DO
8394 ELSE
8395 DO j = jts , MIN(jde-1,jte)
8396 DO i = its , MIN(ide-1,ite)
8397 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8398 tv_sfc = t(i,1,j) * (1. + 0.608 * q(i,1,j))
8399 del_z = height(i,1,j) - ter(i,j)
8400 psfc(i,j) = psfc_in(i,j) * EXP ( g * del_z / ( Rd * tv_sfc ) )
8401 END DO
8402 END DO
8403 END IF
8405 END SUBROUTINE sfcprs2
8407 !---------------------------------------------------------------------
8409 SUBROUTINE sfcprs3( height , p , ter , slp , psfc , &
8410 ids , ide , jds , jde , kds , kde , &
8411 ims , ime , jms , jme , kms , kme , &
8412 its , ite , jts , jte , kts , kte )
8414 ! Computes the surface pressure by vertically interpolating
8415 ! linearly (or log) in z the pressure, to the targeted topography.
8417 IMPLICIT NONE
8419 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
8420 ims , ime , jms , jme , kms , kme , &
8421 its , ite , jts , jte , kts , kte
8423 REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: height, p
8424 REAL , DIMENSION (ims:ime, jms:jme) , INTENT(IN ):: ter , slp
8425 REAL , DIMENSION (ims:ime, jms:jme) , INTENT(OUT):: psfc
8427 INTEGER :: i
8428 INTEGER :: j
8429 INTEGER :: k
8431 LOGICAL :: found_loc
8433 REAL :: zl , zu , pl , pu , zm
8435 ! Loop over each grid point
8437 DO j = jts , MIN(jde-1,jte)
8438 DO i = its , MIN(ide-1,ite)
8439 IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE
8441 ! Special case where near the ocean level. Assume that the SLP is a good value.
8443 IF ( ter(i,j) .LT. 50 ) THEN
8444 psfc(i,j) = slp(i,j) + ( p(i,2,j)-p(i,3,j) ) / ( height(i,2,j)-height(i,3,j) ) * ter(i,j)
8445 CYCLE
8446 END IF
8448 ! Find the trapping levels
8450 found_loc = .FALSE.
8452 ! Normal sort of scenario - the model topography is somewhere between
8453 ! the height values of 1000 mb and the top of the model.
8455 found_k_loc : DO k = kts+1 , kte-2
8456 IF ( ( height(i,k ,j) .LE. ter(i,j) ) .AND. &
8457 ( height(i,k+1,j) .GT. ter(i,j) ) ) THEN
8458 zl = height(i,k ,j)
8459 zu = height(i,k+1,j)
8460 zm = ter(i,j)
8461 pl = p(i,k ,j)
8462 pu = p(i,k+1,j)
8463 psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) )
8464 found_loc = .TRUE.
8465 EXIT found_k_loc
8466 END IF
8467 END DO found_k_loc
8469 ! Interpolate betwixt slp and the first isobaric level above - this is probably the
8470 ! usual thing over the ocean.
8472 IF ( .NOT. found_loc ) THEN
8473 IF ( slp(i,j) .GE. p(i,2,j) ) THEN
8474 zl = 0.
8475 zu = height(i,3,j)
8476 zm = ter(i,j)
8477 pl = slp(i,j)
8478 pu = p(i,3,j)
8479 psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) )
8480 found_loc = .TRUE.
8481 ELSE
8482 found_slp_loc : DO k = kts+1 , kte-3
8483 IF ( ( slp(i,j) .GE. p(i,k+1,j) ) .AND. &
8484 ( slp(i,j) .LT. p(i,k ,j) ) ) THEN
8485 zl = 0.
8486 zu = height(i,k+1,j)
8487 zm = ter(i,j)
8488 pl = slp(i,j)
8489 pu = p(i,k+1,j)
8490 psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) )
8491 found_loc = .TRUE.
8492 EXIT found_slp_loc
8493 END IF
8494 END DO found_slp_loc
8495 END IF
8496 END IF
8498 ! Did we do what we wanted done.
8500 IF ( .NOT. found_loc ) THEN
8501 print *,'i,j = ',i,j
8502 print *,'p column = ',p(i,2:,j)
8503 print *,'z column = ',height(i,2:,j)
8504 print *,'model topo = ',ter(i,j)
8505 CALL wrf_error_fatal ( ' probs with sfc p computation ' )
8506 END IF
8508 END DO
8509 END DO
8511 END SUBROUTINE sfcprs3
8513 !---------------------------------------------------------------------
8515 SUBROUTINE filter_topo ( ht_in , xlat , msftx , &
8516 fft_filter_lat , mf_fft , &
8517 pos_def , swap_pole_with_next_j , &
8518 ids , ide , jds , jde , kds , kde , &
8519 ims , ime , jms , jme , kms , kme , &
8520 its , ite , jts , jte , kts , kte )
8522 IMPLICIT NONE
8524 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
8525 ims , ime , jms , jme , kms , kme , &
8526 its , ite , jts , jte , kts , kte
8528 REAL , INTENT(IN) :: fft_filter_lat , mf_fft
8529 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: ht_in
8530 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx
8531 LOGICAL :: pos_def , swap_pole_with_next_j
8533 ! Local vars
8535 INTEGER :: i , j , j_lat_pos , j_lat_neg , k
8536 INTEGER :: i_kicker , ik , i1, i2, i3, i4
8537 INTEGER :: i_left , i_right , ii
8538 REAL :: length_scale , sum
8539 REAL , DIMENSION(its:ite,jts:jte) :: ht_out
8540 CHARACTER (LEN=256) :: message
8542 ! The filtering is a simple average on a latitude loop. Possibly a LONG list of
8543 ! numbers. We assume that ALL of the 2d arrays have been transposed so that
8544 ! each patch has the entire domain size of the i-dim local.
8546 IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN
8547 CALL wrf_error_fatal ( 'filtering assumes all values on X' )
8548 END IF
8550 ! Starting at the south pole, we find where the
8551 ! grid distance is big enough, then go back a point. Continuing to the
8552 ! north pole, we find the first small grid distance. These are the
8553 ! computational latitude loops and the associated computational poles.
8555 j_lat_neg = 0
8556 j_lat_pos = jde + 1
8557 loop_neg : DO j = MIN(jde-1,jte) , jts , -1
8558 IF ( xlat(its,j) .LT. 0.0 ) THEN
8559 IF ( ABS(xlat(its,j)) .GE. fft_filter_lat ) THEN
8560 j_lat_neg = j
8561 EXIT loop_neg
8562 END IF
8563 END IF
8564 END DO loop_neg
8566 loop_pos : DO j = jts , MIN(jde-1,jte)
8567 IF ( xlat(its,j) .GT. 0.0 ) THEN
8568 IF ( xlat(its,j) .GE. fft_filter_lat ) THEN
8569 j_lat_pos = j
8570 EXIT loop_pos
8571 END IF
8572 END IF
8573 END DO loop_pos
8575 ! Set output values to initial input topo values for whole patch.
8577 DO j = jts , MIN(jde-1,jte)
8578 DO i = its , MIN(ide-1,ite)
8579 ht_out(i,j) = ht_in(i,j)
8580 END DO
8581 END DO
8583 ! Filter the topo at the negative lats.
8585 DO j = MIN(j_lat_neg,jte) , jts , -1
8586 ! i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 )
8587 i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 )
8588 WRITE (message,*) 'SOUTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j)
8589 CALL wrf_debug(10,TRIM(message))
8590 DO i = its , MIN(ide-1,ite)
8591 sum = 0.
8592 DO ik = 1 , i_kicker
8593 ii = i-ik
8594 IF ( ii .GE. ids ) THEN
8595 i_left = ii
8596 ELSE
8597 i_left = ( ii - ids ) + (ide-1)+1
8598 END IF
8599 ii = i+ik
8600 IF ( ii .LE. ide-1 ) THEN
8601 i_right = ii
8602 ELSE
8603 i_right = ( ii - (ide-1) ) + its-1
8604 END IF
8605 sum = sum + ht_in(i_left,j) + ht_in(i_right,j)
8606 END DO
8607 ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8608 END DO
8609 END DO
8611 ! Filter the topo at the positive lats.
8613 DO j = MAX(j_lat_pos,jts) , MIN(jde-1,jte)
8614 ! i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 )
8615 i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 )
8616 WRITE (message,*) 'NORTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j)
8617 CALL wrf_debug(10,TRIM(message))
8618 DO i = its , MIN(ide-1,ite)
8619 sum = 0.
8620 DO ik = 1 , i_kicker
8621 ii = i-ik
8622 IF ( ii .GE. ids ) THEN
8623 i_left = ii
8624 ELSE
8625 i_left = ( ii - ids ) + (ide-1)+1
8626 END IF
8627 ii = i+ik
8628 IF ( ii .LE. ide-1 ) THEN
8629 i_right = ii
8630 ELSE
8631 i_right = ( ii - (ide-1) ) + its-1
8632 END IF
8633 sum = sum + ht_in(i_left,j) + ht_in(i_right,j)
8634 END DO
8635 ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8636 END DO
8637 END DO
8639 ! Set output values to initial input topo values for whole patch.
8641 DO j = jts , MIN(jde-1,jte)
8642 DO i = its , MIN(ide-1,ite)
8643 ht_in(i,j) = ht_out(i,j)
8644 END DO
8645 END DO
8647 END SUBROUTINE filter_topo
8649 !---------------------------------------------------------------------
8650 !---------------------------------------------------------------------
8652 SUBROUTINE filter_topo_old ( ht_in , xlat , msftx , fft_filter_lat , &
8653 dummy , &
8654 ids , ide , jds , jde , kds , kde , &
8655 ims , ime , jms , jme , kms , kme , &
8656 its , ite , jts , jte , kts , kte )
8658 IMPLICIT NONE
8660 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
8661 ims , ime , jms , jme , kms , kme , &
8662 its , ite , jts , jte , kts , kte
8664 REAL , INTENT(IN) :: fft_filter_lat , dummy
8665 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: ht_in
8666 REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx
8669 ! Local vars
8671 INTEGER :: i , j , j_lat_pos , j_lat_neg
8672 INTEGER :: i_kicker , ik , i1, i2, i3, i4
8673 REAL :: length_scale , sum
8674 REAL , DIMENSION(its:ite,jts:jte) :: ht_out
8676 ! The filtering is a simple average on a latitude loop. Possibly a LONG list of
8677 ! numbers. We assume that ALL of the 2d arrays have been transposed so that
8678 ! each patch has the entire domain size of the i-dim local.
8680 IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN
8681 CALL wrf_error_fatal ( 'filtering assumes all values on X' )
8682 END IF
8684 ! Starting at the south pole, we find where the
8685 ! grid distance is big enough, then go back a point. Continuing to the
8686 ! north pole, we find the first small grid distance. These are the
8687 ! computational latitude loops and the associated computational poles.
8689 j_lat_neg = 0
8690 j_lat_pos = jde + 1
8691 loop_neg : DO j = jts , MIN(jde-1,jte)
8692 IF ( xlat(its,j) .LT. 0.0 ) THEN
8693 IF ( ABS(xlat(its,j)) .LT. fft_filter_lat ) THEN
8694 j_lat_neg = j - 1
8695 EXIT loop_neg
8696 END IF
8697 END IF
8698 END DO loop_neg
8700 loop_pos : DO j = jts , MIN(jde-1,jte)
8701 IF ( xlat(its,j) .GT. 0.0 ) THEN
8702 IF ( xlat(its,j) .GE. fft_filter_lat ) THEN
8703 j_lat_pos = j
8704 EXIT loop_pos
8705 END IF
8706 END IF
8707 END DO loop_pos
8709 ! Set output values to initial input topo values for whole patch.
8711 DO j = jts , MIN(jde-1,jte)
8712 DO i = its , MIN(ide-1,ite)
8713 ht_out(i,j) = ht_in(i,j)
8714 END DO
8715 END DO
8717 ! Filter the topo at the negative lats.
8719 DO j = j_lat_neg , jts , -1
8720 i_kicker = MIN( MAX ( NINT(msftx(its,j)) , 1 ) , (ide - ids) / 2 )
8721 print *,'j = ' , j, ', kicker = ',i_kicker
8722 DO i = its , MIN(ide-1,ite)
8723 IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
8724 sum = 0.0
8725 DO ik = 1 , i_kicker
8726 sum = sum + ht_in(i+ik,j) + ht_in(i-ik,j)
8727 END DO
8728 ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8729 ELSE IF ( ( i - i_kicker .LT. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
8730 sum = 0.0
8731 DO ik = 1 , i_kicker
8732 sum = sum + ht_in(i+ik,j)
8733 END DO
8734 i1 = i - i_kicker + ide -1
8735 i2 = ide-1
8736 i3 = ids
8737 i4 = i-1
8738 DO ik = i1 , i2
8739 sum = sum + ht_in(ik,j)
8740 END DO
8741 DO ik = i3 , i4
8742 sum = sum + ht_in(ik,j)
8743 END DO
8744 ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8745 ELSE IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .GT. ide-1 ) ) THEN
8746 sum = 0.0
8747 DO ik = 1 , i_kicker
8748 sum = sum + ht_in(i-ik,j)
8749 END DO
8750 i1 = i+1
8751 i2 = ide-1
8752 i3 = ids
8753 i4 = ids + ( i_kicker+i ) - ide
8754 DO ik = i1 , i2
8755 sum = sum + ht_in(ik,j)
8756 END DO
8757 DO ik = i3 , i4
8758 sum = sum + ht_in(ik,j)
8759 END DO
8760 ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8761 END IF
8762 END DO
8763 END DO
8765 ! Filter the topo at the positive lats.
8767 DO j = j_lat_pos , MIN(jde-1,jte)
8768 i_kicker = MIN( MAX ( NINT(msftx(its,j)) , 1 ) , (ide - ids) / 2 )
8769 print *,'j = ' , j, ', kicker = ',i_kicker
8770 DO i = its , MIN(ide-1,ite)
8771 IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
8772 sum = 0.0
8773 DO ik = 1 , i_kicker
8774 sum = sum + ht_in(i+ik,j) + ht_in(i-ik,j)
8775 END DO
8776 ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8777 ELSE IF ( ( i - i_kicker .LT. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN
8778 sum = 0.0
8779 DO ik = 1 , i_kicker
8780 sum = sum + ht_in(i+ik,j)
8781 END DO
8782 i1 = i - i_kicker + ide -1
8783 i2 = ide-1
8784 i3 = ids
8785 i4 = i-1
8786 DO ik = i1 , i2
8787 sum = sum + ht_in(ik,j)
8788 END DO
8789 DO ik = i3 , i4
8790 sum = sum + ht_in(ik,j)
8791 END DO
8792 ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8793 ELSE IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .GT. ide-1 ) ) THEN
8794 sum = 0.0
8795 DO ik = 1 , i_kicker
8796 sum = sum + ht_in(i-ik,j)
8797 END DO
8798 i1 = i+1
8799 i2 = ide-1
8800 i3 = ids
8801 i4 = ids + ( i_kicker+i ) - ide
8802 DO ik = i1 , i2
8803 sum = sum + ht_in(ik,j)
8804 END DO
8805 DO ik = i3 , i4
8806 sum = sum + ht_in(ik,j)
8807 END DO
8808 ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 )
8809 END IF
8810 END DO
8811 END DO
8813 ! Set output values to initial input topo values for whole patch.
8815 DO j = jts , MIN(jde-1,jte)
8816 DO i = its , MIN(ide-1,ite)
8817 ht_in(i,j) = ht_out(i,j)
8818 END DO
8819 END DO
8821 END SUBROUTINE filter_topo_old
8823 !---------------------------------------------------------------------
8826 !+---+-----------------------------------------------------------------+
8827 ! Begin addition by Greg Thompson to dry out the stratosphere.
8828 ! Starting 3 levels below model top, go downward and search for where
8829 ! Theta gradient over three K-levels is less steep than +10 K per 1500 m.
8830 ! This threshold approximates a vertical line on a skew-T chart from
8831 ! approximately 300 to 240 mb, anything more unstable than this reference
8832 ! is probably in the troposphere so pick the K plus 1 point as the
8833 ! tropopause and set mixing ratio to a really small values above.
8834 !..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805
8835 !..Last modified: 30 Dec 2004
8836 !+---+-----------------------------------------------------------------+
8838 subroutine dry_stratos ( theta, qv, phb, &
8839 ids , ide , jds , jde , kds , kde , &
8840 ims , ime , jms , jme , kms , kme , &
8841 its , ite , jts , jte , kts , kte )
8843 IMPLICIT NONE
8845 INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , &
8846 ims , ime , jms , jme , kms , kme , &
8847 its , ite , jts , jte , kts , kte
8849 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: theta, phb
8850 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: qv
8852 ! Local vars
8854 INTEGER :: i, j, k, kk, istart, iend, jstart, jend, kstart, kend
8855 REAL :: ht1, ht2, theta1, theta2, htz, sat85, p_std_atmos
8856 CHARACTER*256:: str_debug
8857 ! Saturation vapor pressure at T = -85C.
8858 DATA sat85 /0.0235755574/
8860 do i = 1, 256
8861 str_debug(i:i) = char(0)
8862 enddo
8864 istart = its
8865 iend = MIN(ide-1,ite)
8866 jstart = jts
8867 jend = MIN(jde-1,jte)
8868 kstart = kts
8869 kend = kte-1
8870 DO j = jstart, jend
8871 DO i = istart, iend
8872 DO k = kend-3, kstart, -1
8873 ht1 = phb(i,k,j)/9.8
8874 ht2 = phb(i,k+2,j)/9.8
8875 theta1 = theta(i,k,j)
8876 theta2 = theta(i,k+2,j)
8877 if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. (ht1.gt.4000.) ) then
8878 DO kk = k+3, kend
8879 htz = phb(i,kk,j)/9.8
8880 p_std_atmos = exp(log(1.0-htz/44307.692)/0.19)*101325.0
8881 qv(i,kk,j) = 0.622*sat85/(p_std_atmos-sat85)
8882 END DO
8883 goto 79
8884 end if
8885 END DO
8886 79 continue
8887 END DO
8888 END DO
8890 END SUBROUTINE dry_stratos
8892 !+---+-----------------------------------------------------------------+
8893 !..Hardwire snow cover above a pre-specified altitude.
8894 !.. Starting altitude for snow (snow_startz) depends on latitude
8895 !.. and is 3900 m at 35-deg lowering to 250km (linearly) by 65-deg lat.
8896 !.. Alter WEASD linear function from 0 at snow_startz to 999 mm at 4 km.
8897 !.. Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805
8898 !.. Last modified: 27 Dec 2008
8899 !+---+-----------------------------------------------------------------+
8901 real function snowHires (snow_in, latitude, elev, date_str, i,j)
8902 IMPLICIT NONE
8904 REAL, INTENT(IN):: latitude, elev, snow_in
8905 INTEGER, INTENT(IN):: i, j
8906 CHARACTER (LEN=24), INTENT(IN) :: date_str
8908 REAL :: snow_startz, del_lat, season_factor, snow_out
8909 REAL :: gmt
8910 INTEGER :: day_peak, day_of_year, julyr
8911 CHARACTER (LEN=256) :: dbg_msg
8913 CALL get_julgmt ( date_str , julyr , day_of_year , gmt )
8915 if (latitude .gt. 0.0) then
8916 del_lat = (65.-latitude)/(65.-35.)
8917 day_peak = 80
8918 else
8919 del_lat = (-65.-latitude)/(-65.+35.)
8920 day_peak = 264
8921 endif
8923 snow_startz = (3900.-250.)*del_lat + 250.
8924 snow_startz = max(250., min(3900., snow_startz))
8926 season_factor = 1.
8927 snow_out = 0.
8928 IF (elev .GT. snow_startz) THEN
8929 season_factor = ABS(COS((day_of_year - day_peak)*0.5*0.0174533))
8930 snow_out = 0.999*(elev-snow_startz)/(4000.-snow_startz)
8931 write(dbg_msg,*) 'DEBUG_GT_SNOW ', day_of_year, latitude, elev, snow_in, snow_startz, season_factor, snow_out,i, j
8932 CALL wrf_debug (150, dbg_msg)
8933 ENDIF
8935 snowHires = MAX(snow_in, season_factor * snow_out)
8937 END FUNCTION snowHires
8939 !+---+-----------------------------------------------------------------+
8940 !+---+-----------------------------------------------------------------+
8942 real function make_IceNumber (Q_ice, temp)
8944 IMPLICIT NONE
8945 REAL, PARAMETER:: Ice_density = 890.0
8946 REAL, PARAMETER:: PI = 3.1415926536
8947 integer idx_rei
8948 real corr, reice, deice, Q_ice, temp
8949 double precision lambda
8951 !+---+-----------------------------------------------------------------+
8952 !..Table of lookup values of radiative effective radius of ice crystals
8953 !.. as a function of Temperature from -94C to 0C. Taken from WRF RRTMG
8954 !.. radiation code where it is attributed to Jon Egill Kristjansson
8955 !.. and coauthors.
8956 !+---+-----------------------------------------------------------------+
8958 real retab(95)
8959 data retab / &
8960 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
8961 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
8962 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
8963 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
8964 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
8965 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
8966 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
8967 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
8968 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
8969 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
8970 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
8971 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
8972 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
8973 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
8974 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
8975 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
8977 !+---+-----------------------------------------------------------------+
8978 !..From the model 3D temperature field, subtract 179K for which
8979 !.. index value of retab as a start. Value of corr is for
8980 !.. interpolating between neighboring values in the table.
8981 !+---+-----------------------------------------------------------------+
8983 idx_rei = int(temp-179.)
8984 idx_rei = min(max(idx_rei,1),94)
8985 corr = temp - int(temp)
8986 reice = retab(idx_rei)*(1.-corr) + retab(idx_rei+1)*corr
8987 deice = 2.*reice * 1.E-6
8989 !+---+-----------------------------------------------------------------+
8990 !..Now we have the final radiative effective size of ice (as function
8991 !.. of temperature only). This size represents 3rd moment divided by
8992 !.. second moment of the ice size distribution, so we can compute a
8993 !.. number concentration from the mean size and mass mixing ratio.
8994 !.. The mean (radiative effective) diameter is 3./Slope for an inverse
8995 !.. exponential size distribution. So, starting with slope, work
8996 !.. backwords to get number concentration.
8997 !+---+-----------------------------------------------------------------+
8999 lambda = 3.0 / deice
9000 make_IceNumber = Q_ice * lambda*lambda*lambda / (PI*Ice_density)
9002 !+---+-----------------------------------------------------------------+
9003 !..Example1: Common ice size coming from Thompson scheme is about 30 microns.
9004 !.. An example ice mixing ratio could be 0.001 g/kg for a temperature of -50C.
9005 !.. Remember to convert both into MKS units. This gives N_ice=357652 per kg.
9006 !..Example2: Lower in atmosphere at T=-10C matching ~162 microns in retab,
9007 !.. and assuming we have 0.1 g/kg mixing ratio, then N_ice=28122 per kg,
9008 !.. which is 28 crystals per liter of air if the air density is 1.0.
9009 !+---+-----------------------------------------------------------------+
9011 return
9012 end function make_IceNumber
9014 !+---+-----------------------------------------------------------------+
9015 !+---+-----------------------------------------------------------------+
9017 real function make_DropletNumber (Q_cloud, qnwfa, xland)
9019 IMPLICIT NONE
9021 real:: Q_cloud, qnwfa, xland
9023 real, parameter:: PI = 3.1415926536
9024 real, parameter:: am_r = PI*1000./6.
9025 real, dimension(15), parameter:: g_ratio = (/24,60,120,210,336, &
9026 & 504,720,990,1320,1716,2184,2730,3360,4080,4896/)
9027 double precision:: lambda, qnc
9028 real:: q_nwfa, x1, xDc
9029 integer:: nu_c
9031 !+---+
9033 if (qnwfa .le. 0.0) then
9035 if ((xland-1.5).gt.0.) then !--- Ocean
9036 xDc = 17.E-6
9037 nu_c = 12
9038 else !--- Land
9039 xDc = 11.E-6
9040 nu_c = 4
9041 endif
9043 else
9044 q_nwfa = MAX(99.E6, MIN(qnwfa,5.E10))
9045 nu_c = MAX(2, MIN(NINT(2.5E10/q_nwfa), 15))
9047 x1 = MAX(1., MIN(q_nwfa*1.E-9, 10.)) - 1.
9048 xDc = (30. - x1*20./9.) * 1.E-6
9049 endif
9051 lambda = (4.0D0 + nu_c) / xDc
9052 qnc = Q_cloud / g_ratio(nu_c) * lambda*lambda*lambda / am_r
9053 make_DropletNumber = SNGL(qnc)
9055 return
9056 end function make_DropletNumber
9058 !+---+-----------------------------------------------------------------+
9059 !+---+-----------------------------------------------------------------+
9061 real function make_RainNumber (Q_rain, temp)
9063 IMPLICIT NONE
9065 real, intent(in):: Q_rain, temp
9066 double precision:: lambda, N0, qnr
9067 real, parameter:: PI = 3.1415926536
9068 real, parameter:: am_r = PI*1000./6.
9070 !+---+-----------------------------------------------------------------+
9071 !.. Not thrilled with it, but set Y-intercept parameter to Marshal-Palmer value
9072 !.. that basically assumes melting snow becomes typical rain. However, for
9073 !.. -2C < T < 0C, make linear increase in exponent to attempt to keep
9074 !.. supercooled collision-coalescence (warm-rain) similar to drizzle rather
9075 !.. than bigger rain drops. While this could also exist at T>0C, it is
9076 !.. more difficult to assume it directly from having mass and not number.
9077 !+---+-----------------------------------------------------------------+
9079 N0 = 8.E6
9081 if (temp .le. 271.15) then
9082 N0 = 8.E8
9083 elseif (temp .gt. 271.15 .and. temp.lt.273.15) then
9084 N0 = 8. * 10**(279.15-temp)
9085 endif
9087 lambda = SQRT(SQRT(N0*am_r*6.0/Q_rain))
9088 qnr = Q_rain / 6.0 * lambda*lambda*lambda / am_r
9089 make_RainNumber = SNGL(qnr)
9091 return
9092 end function make_RainNumber
9094 !+---+-----------------------------------------------------------------+
9095 !+---+-----------------------------------------------------------------+
9098 SUBROUTINE init_module_initialize
9099 END SUBROUTINE init_module_initialize
9101 !---------------------------------------------------------------------
9103 END MODULE module_initialize_real
9104 #endif