MODULE module_initialize_real USE module_bc USE module_configure USE module_domain USE module_io_domain USE module_model_constants USE module_state_description USE module_timing USE module_soil_pre USE module_date_time USE module_llxy USE module_polarfft USE module_dm USE module_comm_dm, ONLY : & HALO_EM_INIT_1_sub & ,HALO_EM_INIT_2_sub & ,HALO_EM_INIT_3_sub & ,HALO_EM_INIT_4_sub & ,HALO_EM_INIT_5_sub & ,HALO_EM_INIT_6_sub & ,HALO_EM_VINTERP_UV_1_sub REAL , SAVE :: p_top_save INTEGER :: internal_time_loop CONTAINS SUBROUTINE init_domain ( grid ) IMPLICIT NONE TYPE (domain) :: grid INTEGER :: idum1, idum2 CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) CALL init_domain_rk( grid & ,grid%moist,grid%moist_bxs,grid%moist_bxe,grid%moist_bys,grid%moist_bye,grid%moist_btxs,grid%moist_btxe,grid%moist_btys, & grid%moist_btye,grid%dfi_moist,grid%dfi_moist_bxs,grid%dfi_moist_bxe,grid%dfi_moist_bys,grid%dfi_moist_bye,grid%dfi_moist_btxs, & grid%dfi_moist_btxe,grid%dfi_moist_btys,grid%dfi_moist_btye,grid%scalar,grid%scalar_bxs,grid%scalar_bxe,grid%scalar_bys, & grid%scalar_bye,grid%scalar_btxs,grid%scalar_btxe,grid%scalar_btys,grid%scalar_btye,grid%dfi_scalar,grid%dfi_scalar_bxs, & grid%dfi_scalar_bxe,grid%dfi_scalar_bys,grid%dfi_scalar_bye,grid%dfi_scalar_btxs,grid%dfi_scalar_btxe,grid%dfi_scalar_btys, & grid%dfi_scalar_btye,grid%aerod,grid%aerocu,grid%ozmixm,grid%aerosolc_1,grid%aerosolc_2,grid%fdda3d,grid%fdda2d,grid%advh_t, & grid%advz_t,grid%tracer,grid%tracer_bxs,grid%tracer_bxe,grid%tracer_bys,grid%tracer_bye,grid%tracer_btxs,grid%tracer_btxe, & grid%tracer_btys,grid%tracer_btye,grid%pert3d,grid%nba_mij,grid%nba_rij,grid%sbmradar,grid%chem & ) END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ,moist,moist_bxs,moist_bxe,moist_bys,moist_bye,moist_btxs,moist_btxe,moist_btys,moist_btye,dfi_moist,dfi_moist_bxs,dfi_moist_bxe, & dfi_moist_bys,dfi_moist_bye,dfi_moist_btxs,dfi_moist_btxe,dfi_moist_btys,dfi_moist_btye,scalar,scalar_bxs,scalar_bxe,scalar_bys, & scalar_bye,scalar_btxs,scalar_btxe,scalar_btys,scalar_btye,dfi_scalar,dfi_scalar_bxs,dfi_scalar_bxe,dfi_scalar_bys, & dfi_scalar_bye,dfi_scalar_btxs,dfi_scalar_btxe,dfi_scalar_btys,dfi_scalar_btye,aerod,aerocu,ozmixm,aerosolc_1,aerosolc_2,fdda3d, & fdda2d,advh_t,advz_t,tracer,tracer_bxs,tracer_bxe,tracer_bys,tracer_bye,tracer_btxs,tracer_btxe,tracer_btys,tracer_btye,pert3d, & nba_mij,nba_rij,sbmradar,chem & ) USE module_optional_input USE module_radiation_driver, ONLY: cal_cldfra3 USE module_dm, ONLY : wrf_dm_max_real use module_madwrf, only : Init_madwrf_clouds, Init_madwrf_tracers IMPLICIT NONE TYPE (domain) :: grid real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_moist) :: moist real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_bxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_bxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_bys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_bye real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_btxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_btxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_btys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_btye real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_dfi_moist) :: dfi_moist real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_bxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_bxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_bys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_bye real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_btxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_btxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_btys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_btye real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_scalar) :: scalar real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_bxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_bxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_bys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_bye real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_btxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_btxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_btys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_btye real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_dfi_scalar) :: dfi_scalar real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_bxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_bxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_bys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_bye real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_btxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_btxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_btys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_btye real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_aerod) :: aerod real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_aerocu) :: aerocu real ,DIMENSION(grid%sm31:grid%em31,1:grid%levsiz,grid%sm33:grid%em33,num_ozmixm) :: ozmixm real ,DIMENSION(grid%sm31:grid%em31,1:grid%paerlev,grid%sm33:grid%em33,num_aerosolc) :: aerosolc_1 real ,DIMENSION(grid%sm31:grid%em31,1:grid%paerlev,grid%sm33:grid%em33,num_aerosolc) :: aerosolc_2 real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_fdda3d) :: fdda3d real ,DIMENSION(grid%sm31:grid%em31,1:1,grid%sm33:grid%em33,num_fdda2d) :: fdda2d real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_advh_t) :: advh_t real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_advz_t) :: advz_t real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_tracer) :: tracer real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_bxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_bxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_bys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_bye real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_btxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_btxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_btys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_btye real ,DIMENSION(grid%sm31:grid%em31,1:grid%num_stoch_levels,grid%sm33:grid%em33,num_pert3d) :: pert3d real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_nba_mij) :: nba_mij real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_nba_rij) :: nba_rij real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_sbmradar) :: sbmradar real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_chem) :: chem TYPE (grid_config_rec_type) :: config_flags INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat INTEGER :: loop , num_seaice_changes INTEGER :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte, & ips, ipe, jps, jpe, kps, kpe, & i, j, k, kk INTEGER :: imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, kpex, & imsy, imey, jmsy, jmey, kmsy, kmey, & ipsy, ipey, jpsy, jpey, kpsy, kpey INTEGER :: ns INTEGER :: error INTEGER :: im, num_3d_m, num_3d_s REAL :: B1, B2, B3, B4, B5 REAL :: p_surf, p_level REAL :: cof1, cof2 REAL :: qvf , qvf1 , qvf2 , qtot, pd_surf REAL :: p00 , t00 , a , tiso, p_strat, a_strat REAL :: hold_znw , ptemp REAL :: vap_pres_mb , sat_vap_pres_mb LOGICAL :: were_bad LOGICAL :: stretch_grid, dry_sounding, debug INTEGER :: IICOUNT, icount REAL :: p_top_requested , temp INTEGER :: num_metgrid_levels INTEGER, PARAMETER :: num_wif_levels_default = 30 INTEGER :: aer_init_opt REAL , DIMENSION(max_eta) :: eta_levels INTEGER :: auto_levels_opt REAL :: max_dz, dzbot, dzstretch_s, dzstretch_u, z1 INTEGER:: i_end, j_end REAL, ALLOCATABLE, DIMENSION(:):: temp_P, temp_T, temp_R, temp_Dz REAL, ALLOCATABLE, DIMENSION(:):: temp_Qv, temp_Qc, temp_Qi, temp_Qs REAL, ALLOCATABLE, DIMENSION(:):: temp_CF, temp_Nc, temp_Ni REAL:: max_relh, temp_xland, gridkm LOGICAL :: debug_flag = .FALSE. REAL :: dclat integer::oops1,oops2 REAL :: zap_close_levels INTEGER :: force_sfc_in_vinterp INTEGER :: interp_type , lagrange_order , extrap_type , t_extrap_type INTEGER :: linear_interp LOGICAL :: lowest_lev_from_sfc , use_levels_below_ground , use_surface LOGICAL :: we_have_tavgsfc , we_have_tsk INTEGER :: lev500 , loop_count REAL :: zl , zu , pl , pu , z500 , dz500 , tvsfc , dpmu REAL :: pfu, pfd, phm LOGICAL , PARAMETER :: want_full_levels = .TRUE. LOGICAL , PARAMETER :: want_half_levels = .FALSE. CHARACTER (LEN=256) :: a_message, mminlu REAL :: max_mf LOGICAL :: any_valid_points INTEGER :: i_valid , j_valid INTEGER :: k_max_p , k_min_p REAL , DIMENSION(100) :: lqmi REAL , DIMENSION(100) :: thickness , levels REAL :: t_start , t_end REAL , ALLOCATABLE , DIMENSION(:,:) :: clat_glob INTEGER :: ks, ke, id LOGICAL :: vnest INTEGER :: j_save INTEGER :: change_soil, change_soilw, iforce REAL:: temp_rho LOGICAL :: wif_upside_down = .FALSE. INTEGER :: geogrid_flag_error REAL :: press_above, press_below CALL cpu_time(t_start) CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe, & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, kpex, & imsy, imey, jmsy, jmey, kmsy, kmey, & ipsy, ipey, jpsy, jpey, kpsy, kpey ) its = ips ; ite = ipe ; jts = jps ; jte = jpe ; kts = kps ; kte = kpe CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) IF ( grid%v4_metgrid ) THEN geogrid_flag_error = 0 IF ( ( config_flags%topo_wind .EQ. 1 ) .AND. ( flag_var_sso .EQ. 0 ) ) THEN CALL wrf_message ( '----- ERROR: topo_wind = 1 AND flag_var_sso = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF IF ( ( config_flags%sf_lake_physics .EQ. 1 ) .AND. ( flag_lake_depth .EQ. 0 ) ) THEN CALL wrf_message ( '----- ERROR: sf_lake_physics = 1 AND flag_lake_depth = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF IF ( ( config_flags%sf_surface_physics .EQ. pxlsmscheme ) .AND. ( flag_imperv .EQ. 0 ) ) THEN CALL wrf_message ( '----- ERROR: sf_surface_physics = 7 AND flag_imperv = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF IF ( ( config_flags%sf_surface_physics .EQ. pxlsmscheme ) .AND. ( flag_canfra .EQ. 0 ) ) THEN CALL wrf_message ( '----- ERROR: sf_surface_physics = 7 AND flag_canfra = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF IF ( ( (config_flags%mp_physics .EQ. thompsonaero .OR. & config_flags%mp_physics .EQ. rcon_mp_scheme & ) ) .AND. & ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_erod .EQ. 0 ) ) THEN CALL wrf_message ( '----- ERROR: mp=28 or mp=29 AND dust_emis= 1 AND flag_erod = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF IF ( ( (config_flags%mp_physics .EQ. thompsonaero .OR. & config_flags%mp_physics .EQ. rcon_mp_scheme & ) ) .AND. & ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_clayfrac .EQ. 0 ) ) THEN CALL wrf_message ( '----- ERROR: mp=28 or mp=29 AND dust_emis= 1 AND flag_clayfrac = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF IF ( ( (config_flags%mp_physics .EQ. thompsonaero .OR. & config_flags%mp_physics .EQ. rcon_mp_scheme & ) ) .AND. & ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_sandfrac .EQ. 0 ) ) THEN CALL wrf_message ( '----- ERROR: mp=28 or mp=29 AND dust_emis= 1 AND flag_sandfrac = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF IF ( geogrid_flag_error .GT. 0 ) THEN CALL wrf_error_fatal3("",353,& 'Either modify the namelist settings, or rebuild the geogrid/metgrid data' ) END IF END IF flag_pmaxw = 0 flag_pmaxwnn = 0 flag_ptrop = 0 flag_ptropnn = 0 IF ( ( config_flags%use_maxw_level .EQ. 0 ) .AND. & ( ( flag_tmaxw .EQ. 1 ) .OR. ( flag_umaxw .EQ. 1 ) .OR. ( flag_vmaxw .EQ. 1 ) .OR. ( flag_hgtmaxw .EQ. 1 ) ) ) THEN flag_tmaxw = 0 flag_umaxw = 0 flag_vmaxw = 0 flag_hgtmaxw = 0 CALL wrf_debug ( 0 , 'Turning off use of MAX WIND level data in vertical interpolation' ) END IF IF ( ( config_flags%use_trop_level .EQ. 0 ) .AND. & ( ( flag_ttrop .EQ. 1 ) .OR. ( flag_utrop .EQ. 1 ) .OR. ( flag_vtrop .EQ. 1 ) .OR. ( flag_hgttrop .EQ. 1 ) ) ) THEN flag_ttrop = 0 flag_utrop = 0 flag_vtrop = 0 flag_hgttrop = 0 CALL wrf_debug ( 0 , 'Turning off use of TROPOPAUSE level data in vertical interpolation' ) END IF CALL nl_get_iswater ( grid%id , grid%iswater ) CALL nl_get_islake ( grid%id , grid%islake ) DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( grid%lu_index(i,j) .NE. grid%islake ) THEN grid%lakemask(i,j) = 0 ELSE grid%lakemask(i,j) = 1 END IF END DO END DO IF ( grid%sf_lake_physics .EQ. 1 ) THEN grid%lake_depth_flag = flag_lake_depth IF ( flag_lake_depth .EQ. 0 ) THEN CALL wrf_message ( " Warning: Please rerun WPS to get lake_depth information for lake model" ) ELSE DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( ( grid%lu_index(i,j) .NE. grid%islake ) .AND. ( grid%lu_index(i,j) .NE. grid%iswater ) ) THEN grid%lake_depth(i,j) = -2 ELSE IF ( grid%lu_index(i,j) .NE. grid%islake ) THEN grid%lake_depth(i,j) = -3 END IF END DO END DO END IF END IF grid%bathymetry_flag = flag_bathymetry IF ( flag_bathymetry .EQ. 0 ) THEN IF ( grid%shalwater_z0 .EQ. 1 ) THEN CALL wrf_message ( " Warning: No bathymetry data found for shallow water roughness model." ) IF ( grid%shalwater_depth .LE. 0.0 ) THEN CALL wrf_message ( " Warning: shalwater_depth must be greater than 0.0 for WRF to run." ) END IF END IF DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) grid%water_depth(i,j) = -4.0 END DO END DO ELSE 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)." ) DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) grid%water_depth(i,j) = grid%bathymetry(i,j) IF ( grid%lu_index(i,j) .EQ. grid%islake ) THEN grid%water_depth(i,j) = grid%bathymetry(i,j) - grid%ht_gc(i,j) END IF grid%water_depth(i,j) = -grid%water_depth(i,j) IF ( ( grid%lu_index(i,j) .NE. grid%islake ) .AND. ( grid%lu_index(i,j) .NE. grid%iswater ) ) THEN grid%water_depth(i,j) = -2.0 ELSE IF (grid%water_depth(i,j) .LT. 0.1) THEN grid%water_depth(i,j) = 0.1 END IF END IF END DO END DO END IF IF ( ( internal_time_loop .EQ. 1 ) .AND. ( grid%id .EQ. 1 ) .AND. & ( .NOT. config_flags%polar ) ) THEN max_mf = grid%msft(its,jts) DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) max_mf = MAX ( max_mf , grid%msft(i,j) ) END DO END DO max_mf = wrf_dm_max_real ( max_mf ) WRITE ( a_message , FMT='(A,F5.2,A)' ) 'Max map factor in domain 1 = ',max_mf, & '. Scale the dt in the model accordingly.' CALL wrf_message ( a_message ) END IF CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) grid%step_number = 0 grid%itimestep=0 grid%real_data_init_type = model_config_rec%real_data_init_type CALL const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat ) grid%t00 = t00 grid%p00 = p00 grid%tlp = a grid%tiso = tiso grid%p_strat = p_strat grid%tlp_strat = a_strat hold_ups = ( internal_time_loop .EQ. 1 ) .OR. & ( config_flags%grid_fdda .NE. 0 ) .OR. & ( config_flags%sst_update .EQ. 1 ) .OR. & ( config_flags%qna_update .EQ. 1 ) .OR. & ( config_flags%all_ic_times ) .OR. & ( config_flags%polar ) IF ( flag_excluded_middle .NE. 0 ) THEN IF ( hold_ups ) THEN WRITE ( a_message,* ) 'None of the following are allowed to be TRUE : ' CALL wrf_message ( a_message ) WRITE ( a_message,* ) ' ( internal_time_loop .EQ. 1 ) ', ( internal_time_loop .EQ. 1 ) CALL wrf_message ( a_message ) WRITE ( a_message,* ) ' ( config_flags%grid_fdda .NE. 0 ) ', ( config_flags%grid_fdda .NE. 0 ) CALL wrf_message ( a_message ) WRITE ( a_message,* ) ' ( config_flags%sst_update .EQ. 1 ) ', ( config_flags%sst_update .EQ. 1 ) CALL wrf_message ( a_message ) WRITE ( a_message,* ) ' ( config_flags%qna_update .EQ. 1 ) ', ( config_flags%qna_update .EQ. 1 ) CALL wrf_message ( a_message ) WRITE ( a_message,* ) ' ( config_flags%all_ic_times ) ', ( config_flags%all_ic_times ) CALL wrf_message ( a_message ) WRITE ( a_message,* ) ' ( config_flags%smooth_cg_topo ) ', ( config_flags%smooth_cg_topo ) CALL wrf_message ( a_message ) WRITE ( a_message,* ) ' ( config_flags%polar ) ', ( config_flags%polar ) CALL wrf_message ( a_message ) WRITE ( a_message,* ) 'Problems, we cannot have excluded middle data from WPS' CALL wrf_error_fatal3("",557,& a_message ) END IF IF ( config_flags%spec_bdy_width .GT. flag_excluded_middle ) THEN WRITE ( a_message,* ) 'The WRF &bdy_control namelist.input spec_bdy_width = ', config_flags%spec_bdy_width CALL wrf_message ( a_message ) WRITE ( a_message,* ) 'The WPS &metgrid namelist.wps process_only_bdy width = ',flag_excluded_middle CALL wrf_message ( a_message ) WRITE ( a_message,* ) 'WPS process_only_bdy must be >= WRF spec_bdy_width' CALL wrf_error_fatal3("",570,& a_message ) END IF END IF em_width = config_flags%spec_bdy_width any_valid_points = .false. find_valid : DO j = jts,jte DO i = its,ite IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE any_valid_points = .true. i_valid = i j_valid = j EXIT find_valid END DO END DO find_valid IF ( flag_icefrac .EQ. 1 ) THEN DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%xice(i,j) = grid%icefrac_gc(i,j) END DO END DO END IF IF ( flag_icepct .EQ. 1 ) THEN DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%xice(i,j) = grid%icepct(i,j)/100. END DO END DO END IF IF ( ( flag_snow .EQ. 0 ) .AND. ( flag_snowh .EQ. 0 ) ) THEN DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%snow(i,j) = 0. grid%snowh(i,j) = 0. END DO END DO ELSE IF ( ( flag_snow .EQ. 0 ) .AND. ( flag_snowh .EQ. 1 ) ) THEN DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%snow(i,j) = grid%snowh(i,j) * 1000. / 5. END DO END DO ELSE IF ( ( flag_snow .EQ. 1 ) .AND. ( flag_snowh .EQ. 0 ) ) THEN DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%snowh(i,j) = grid%snow(i,j) / 1000. * 5. END DO END DO END IF IF ( ( config_flags%polar ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN DO j=max(jds+1,jts),min(jde-1,jte) DO i=its,min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j) END DO END DO IF(jts == jds) THEN DO i=its,ite IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%msfvx(i,jts) = 0. grid%msfvx_inv(i,jts) = 0. END DO END IF IF(jte == jde) THEN DO i=its,ite IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%msfvx(i,jte) = 0. grid%msfvx_inv(i,jte) = 0. END DO END IF ELSE IF ( ( .NOT. config_flags%polar ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN IF ( grid%msfvx(its,jts) .EQ. 0 ) THEN CALL wrf_error_fatal3("",670,& 'Maybe this is a global domain, but the polar flag was not set in the bdy_control namelist.' ) END IF DO j=jts,min(jde,jte) DO i=its,min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j) END DO END DO ELSE IF ( ( config_flags%polar ) .AND. ( flag_mf_xy .NE. 1 ) ) THEN CALL wrf_error_fatal3("",680,& 'Older metgrid data cannot initialize a global domain' ) ENDIF IF ( flag_tavgsfc .EQ. 1 ) THEN we_have_tavgsfc = .TRUE. ELSE we_have_tavgsfc = .FALSE. END IF IF ( flag_tsk .EQ. 1 ) THEN we_have_tsk = .TRUE. ELSE we_have_tsk = .FALSE. END IF IF ( config_flags%use_tavg_for_tsk ) THEN IF ( we_have_tsk .OR. we_have_tavgsfc ) THEN ELSE CALL wrf_error_fatal3("",702,& 'We either need TSK or TAVGSFC, verify these fields are coming from WPS' ) END IF IF ( we_have_tavgsfc ) THEN DO j=jts,min(jde,jte) DO i=its,min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%tsk(i,j) = grid%tavgsfc(i,j) END DO END DO END IF END IF IF (config_flags%slucm_distributed_drag) THEN CALL wrf_message('Adding zero-plane displacement height to topography') DO j = jts, MIN(jde - 1, jte) DO i = its, MIN(ide - 1, ite) IF (grid%zd_urb2d(i, j) > 0) grid%ht_gc(i, j) = grid%ht_gc(i, j) + grid%zd_urb2d(i, j) END DO END DO END IF IF ( flag_metgrid .EQ. 1 ) THEN num_metgrid_levels = grid%num_metgrid_levels IF ( config_flags%nest_interp_coord .EQ. 1 ) THEN DO j=jts,jte DO i=its,ite IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%max_p(i,j) = grid%p_gc(i,1,j) k_max_p = 1 IF ( grid%p_gc(i,2,j) .GT. grid%max_p(i,j) ) THEN grid%max_p(i,j) = grid%p_gc(i,2,j) k_max_p = 2 ELSE IF ( grid%p_gc(i,num_metgrid_levels,j) .GT. grid%max_p(i,j) ) THEN grid%max_p(i,j) = grid%p_gc(i,num_metgrid_levels,j) k_max_p = num_metgrid_levels END IF grid%t_max_p(i,j) = grid%t_gc(i,k_max_p,j) grid%ght_max_p(i,j) = grid%ght_gc(i,k_max_p,j) grid%min_p(i,j) = grid%p_gc(i,num_metgrid_levels,j) k_min_p = num_metgrid_levels IF ( grid%p_gc(i,2,j) .LT. grid%min_p(i,j) ) THEN grid%min_p(i,j) = grid%p_gc(i,2,j) k_min_p = 2 END IF grid%t_min_p(i,j) = grid%t_gc(i,k_min_p,j) grid%ght_min_p(i,j) = grid%ght_gc(i,k_min_p,j) END DO END DO END IF IF ( flag_pinterp .EQ. 1 ) THEN WRITE ( a_message , * ) 'Data from P_INTERP program, filling k=1 level with artificial surface fields.' CALL wrf_message ( a_message ) DO j=jts,jte DO i=its,ite IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%u_gc(i,1,j) = grid%u_gc(i,2,j) grid%v_gc(i,1,j) = grid%v_gc(i,2,j) grid%rh_gc(i,1,j) = grid%rh_gc(i,2,j) grid%t_gc(i,1,j) = grid%t2(i,j) grid%ght_gc(i,1,j) = grid%ht(i,j) grid%p_gc(i,1,j) = grid%psfc(i,j) END DO END DO flag_psfc = 0 END IF DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%tsk(i,j) = grid%tsk_gc(i,j) grid%tmn(i,j) = grid%tmn_gc(i,j) grid%xlat(i,j) = grid%xlat_gc(i,j) grid%xlong(i,j) = grid%xlong_gc(i,j) grid%ht(i,j) = grid%ht_gc(i,j) END DO END DO IF ( ( config_flags%smooth_cg_topo ) .AND. & ( internal_time_loop .EQ. 1 ) .AND. & ( grid%id .EQ. 1 ) .AND. & ( flag_soilhgt .NE. 1) ) THEN CALL wrf_message (' --- ERROR: NML option smooth_cg_topo=T') CALL wrf_message (' But found no soil elevation / terrain / topography data in metgrid files') CALL wrf_message (' The field SOILHGT is required when smoothing the CG topography on d01') CALL wrf_error_fatal3("",828,& ' If using ERA5 data, possibly need to add more time invariant fields') END IF IF ( ( config_flags%smooth_cg_topo ) .AND. & ( internal_time_loop .EQ. 1 ) .AND. & ( grid%id .EQ. 1 ) .AND. & ( flag_soilhgt .EQ. 1) ) THEN CALL blend_terrain ( grid%toposoil , grid%ht , & ids , ide , jds , jde , 1 , 1 , & ims , ime , jms , jme , 1 , 1 , & ips , ipe , jps , jpe , 1 , 1 ) DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%ht_smooth(i,j) = grid%ht(i,j) END DO END DO ELSE IF ( ( config_flags%smooth_cg_topo ) .AND. & ( internal_time_loop .NE. 1 ) .AND. & ( grid%id .EQ. 1 ) .AND. & ( flag_soilhgt .EQ. 1) ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%ht(i,j) = grid%ht_smooth(i,j) END DO END DO END IF IF ( ( config_flags%polar ) .AND. ( grid%fft_filter_lat .GT. 90 ) ) THEN CALL wrf_error_fatal3("",861,& 'If the polar boundary condition is used, then fft_filter_lat must be set in namelist.input' ) END IF IF ( ( config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( config_flags%polar ) ) THEN dclat = 90./REAL(jde-jds) DO j = jts, MIN(jte,jde-1) DO k = kts, kte DO i = its, MIN(ite,ide-1) grid%t_2(i,k,j) = 1. END DO END DO DO i = its, MIN(ite,ide-1) grid%t_2(i,1,j) = grid%ht(i,j) grid%sr(i,j) = grid%ht(i,j) END DO END DO ALLOCATE( clat_glob(ids:ide,jds:jde) ) CALL wrf_patch_to_global_real ( grid%clat, clat_glob, grid%domdesc, 'xy', 'xy', & ids, ide, jds, jde, 1, 1, & ims, ime, jms, jme, 1, 1, & its, ite, jts, jte, 1, 1 ) CALL wrf_dm_bcast_real ( clat_glob , (ide-ids+1)*(jde-jds+1) ) grid%clat_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex) find_j_index_of_fft_filter : DO j = jds , jde-1 IF ( ABS(clat_glob(ids,j)) .LE. config_flags%fft_filter_lat ) THEN j_save = j EXIT find_j_index_of_fft_filter END IF END DO find_j_index_of_fft_filter CALL wrf_patch_to_global_real ( grid%msft, clat_glob, grid%domdesc, 'xy', 'xy', & ids, ide, jds, jde, 1, 1, & ims, ime, jms, jme, 1, 1, & its, ite, jts, jte, 1, 1 ) CALL wrf_dm_bcast_real ( clat_glob , (ide-ids+1)*(jde-jds+1) ) grid%mf_fft = clat_glob(ids,j_save) grid%mf_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex) DEALLOCATE( clat_glob ) CALL pxft ( grid=grid & ,lineno=828 & ,flag_uv = 0 & ,flag_rurv = 0 & ,flag_wph = 0 & ,flag_ww = 0 & ,flag_t = 1 & ,flag_mu = 0 & ,flag_mut = 0 & ,flag_moist = 0 & ,flag_chem = 0 & ,flag_tracer = 0 & ,flag_scalar = 0 & ,actual_distance_average = .TRUE. & ,pos_def = .FALSE. & ,swap_pole_with_next_j = .FALSE. & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe & ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%ht(i,j) = grid%t_2(i,1,j) grid%sr(i,j) = grid%sr(i,j) - grid%ht(i,j) END DO END DO ELSE IF ( ( config_flags%map_proj .NE. PROJ_CASSINI ) .AND. ( config_flags%polar ) ) THEN WRITE ( a_message,* ) 'A global domain (polar = true) requires the Cassini projection' CALL wrf_error_fatal3("",944,& a_message ) END IF IF ( flag_psfc .EQ. 1 ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%psfc_gc(i,j) = grid%psfc(i,j) grid%p_gc(i,1,j) = grid%psfc(i,j) END DO END DO END IF IF ( flag_soilhgt .EQ. 1) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%ght_gc(i,1,j) = grid%toposoil(i,j) grid%ht_gc(i,j)= grid%toposoil(i,j) END DO END DO END IF num_metgrid_levels = grid%num_metgrid_levels IF ( flag_ptheta .EQ. 1 ) THEN DO j = jts, MIN(jte,jde-1) DO k = 1 , num_metgrid_levels DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE ptemp = grid%p_gc(i,k,j) grid%p_gc(i,k,j) = grid%prho_gc(i,k,j) grid%prho_gc(i,k,j) = ptemp END DO END DO END DO END IF IF ( ( flag_ptheta .EQ. 1 ) .OR. ( flag_prho .EQ. 1 ) ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 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 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 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 END DO END DO IF ( grid%sh_gc(its,1,jts) .LT. 0 ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid% sh_gc(i,1,j) = 2. * grid% sh_gc(i,num_metgrid_levels,j) - grid% sh_gc(i,num_metgrid_levels-1,j) END DO END DO END IF IF ( grid%cl_gc(its,1,jts) .LT. 0 ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid% cl_gc(i,1,j) = 2. * grid% cl_gc(i,num_metgrid_levels,j) - grid% cl_gc(i,num_metgrid_levels-1,j) END DO END DO END IF IF ( grid%cf_gc(its,1,jts) .LT. 0 ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid% cf_gc(i,1,j) = 2. * grid% cf_gc(i,num_metgrid_levels,j) - grid% cf_gc(i,num_metgrid_levels-1,j) END DO END DO END IF END IF IF ( flag_prho .EQ. 1 ) THEN levels(1) = 0. levels(2) = ( 2. * sm_levels_input(1) ) DO k = 2 , num_sm_levels_input levels(k+1) = ( 2. * sm_levels_input(k) ) - levels(k) END DO DO k = 1 , num_sm_levels_input thickness(k) = ( levels(k+1) - levels(k) ) / 100. END DO DO j = jts, MIN(jte,jde-1) DO k = 1 , num_sm_levels_input DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE sm_input(i,k+1,j) = MAX ( 0. , sm_input(i,k+1,j) / 1000. / thickness(k) ) END DO END DO END DO END IF IF ( any_valid_points ) THEN IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN k = 2 ELSE k = num_metgrid_levels END IF IF ( grid%t_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%t_gc(i,1,j) = grid%t_gc(i,k,j) END DO END DO config_flags%use_surface = .FALSE. grid%use_surface = .FALSE. WRITE ( a_message , * ) 'Missing surface temp, replaced with closest level, use_surface set to false.' CALL wrf_message ( a_message ) END IF IF ( grid%rh_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%rh_gc(i,1,j) = grid%rh_gc(i,k,j) END DO END DO config_flags%use_surface = .FALSE. grid%use_surface = .FALSE. WRITE ( a_message , * ) 'Missing surface RH, replaced with closest level, use_surface set to false.' CALL wrf_message ( a_message ) END IF IF ( grid%u_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, ite IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%u_gc(i,1,j) = grid%u_gc(i,k,j) END DO END DO config_flags%use_surface = .FALSE. grid%use_surface = .FALSE. WRITE ( a_message , * ) 'Missing surface u wind, replaced with closest level, use_surface set to false.' CALL wrf_message ( a_message ) END IF IF ( grid%v_gc(i_valid,1,j_valid) .EQ. -1.E30 ) THEN DO j = jts, jte DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%v_gc(i,1,j) = grid%v_gc(i,k,j) END DO END DO config_flags%use_surface = .FALSE. grid%use_surface = .FALSE. WRITE ( a_message , * ) 'Missing surface v wind, replaced with closest level, use_surface set to false.' CALL wrf_message ( a_message ) END IF IF ( ( flag_qv .NE. 1 ) .AND. ( flag_sh .NE. 1 ) ) THEN IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN k = 2 ELSE k = num_metgrid_levels END IF config_flags%use_sh_qv = .FALSE. IF ( config_flags%rh2qv_method .eq. 1 ) THEN CALL rh_to_mxrat1(grid%rh_gc, grid%t_gc, grid%p_gc, grid%qv_gc , & config_flags%rh2qv_wrt_liquid , & config_flags%qv_max_p_safe , & config_flags%qv_max_flag , config_flags%qv_max_value , & config_flags%qv_min_p_safe , & config_flags%qv_min_flag , config_flags%qv_min_value , & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) ELSE IF ( config_flags%rh2qv_method .eq. 2 ) THEN CALL rh_to_mxrat2(grid%rh_gc, grid%t_gc, grid%p_gc, grid%qv_gc , & config_flags%rh2qv_wrt_liquid , & config_flags%qv_max_p_safe , & config_flags%qv_max_flag , config_flags%qv_max_value , & config_flags%qv_min_p_safe , & config_flags%qv_min_flag , config_flags%qv_min_value , & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) END IF ELSE IF ( flag_sh .EQ. 1 ) THEN IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN k = 2 ELSE k = num_metgrid_levels END IF IF ( grid%sh_gc(i_valid,kts,j_valid) .LT. 1.e-6 ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%sh_gc(i,1,j) = grid%sh_gc(i,k,j) END DO END DO END IF DO j = jts, MIN(jte,jde-1) DO k = 1 , num_metgrid_levels DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%qv_gc(i,k,j) = grid%sh_gc(i,k,j) /( 1. - grid%sh_gc(i,k,j) ) 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)) vap_pres_mb = grid%qv_gc(i,k,j) * grid%p_gc(i,k,j)/100. / (grid%qv_gc(i,k,j) + 0.622 ) IF ( sat_vap_pres_mb .GT. 0 ) THEN grid%rh_gc(i,k,j) = ( vap_pres_mb / sat_vap_pres_mb ) * 100. ELSE grid%rh_gc(i,k,j) = 0. END IF END DO END DO END DO ELSE IF ( flag_qv .EQ. 1 ) THEN IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN k = 2 ELSE k = num_metgrid_levels END IF DO j = jts, MIN(jte,jde-1) DO k = 1 , num_metgrid_levels DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 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)) vap_pres_mb = grid%qv_gc(i,k,j) * grid%p_gc(i,k,j)/100. / (grid%qv_gc(i,k,j) + 0.622 ) IF ( sat_vap_pres_mb .GT. 0 ) THEN grid%rh_gc(i,k,j) = ( vap_pres_mb / sat_vap_pres_mb ) * 100. ELSE grid%rh_gc(i,k,j) = 0. END IF END DO END DO END DO END IF IF ( grid%ght_gc(i_valid,grid%num_metgrid_levels/2,j_valid) .LT. 1 ) THEN DO j = jts, MIN(jte,jde-1) DO k = kts+1 , grid%num_metgrid_levels DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%ght_gc(i,k,j) = grid%ght_gc(i,k-1,j) - & R_d / g * 0.5 * ( grid%t_gc(i,k ,j) * ( 1 + 0.608 * grid%qv_gc(i,k ,j) ) + & grid%t_gc(i,k-1,j) * ( 1 + 0.608 * grid%qv_gc(i,k-1,j) ) ) * & LOG ( grid%p_gc(i,k,j) / grid%p_gc(i,k-1,j) ) END DO END DO END DO END IF 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 config_flags%sfcp_to_sfcp = .TRUE. END IF END IF DO j = jts, min(jde-1,jte) DO i = its, min(ide,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%u10(i,j)=grid%u_gc(i,1,j) END DO END DO DO j = jts, min(jde,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%v10(i,j)=grid%v_gc(i,1,j) END DO END DO DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%t2(i,j)=grid%t_gc(i,1,j) END DO END DO IF ( flag_qv .EQ. 1 ) THEN DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%q2(i,j)=grid%qv_gc(i,1,j) END DO END DO END IF IF ( flag_sh .EQ. 1 ) THEN DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%q2(i,j)=grid%qv_gc(i,1,j) END DO END DO END IF p_top_requested = grid%p_top_requested IF ( internal_time_loop .EQ. 1 ) THEN CALL find_p_top ( grid%p_gc , grid%p_top , & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) grid%p_top = wrf_dm_max_real ( grid%p_top ) IF ( p_top_requested .LT. grid%p_top ) THEN print *,'p_top_requested = ',p_top_requested print *,'allowable grid%p_top in data = ',grid%p_top CALL wrf_error_fatal3("",1303,& 'p_top_requested < grid%p_top possible from data' ) END IF grid%p_top = p_top_requested p_top_save = grid%p_top ELSE CALL find_p_top ( grid%p_gc , grid%p_top , & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) grid%p_top = wrf_dm_max_real ( grid%p_top ) IF ( grid%p_top .GT. p_top_save ) THEN print *,'grid%p_top from last time period = ',p_top_save print *,'grid%p_top from this time period = ',grid%p_top CALL wrf_error_fatal3("",1329,& 'grid%p_top > previous value' ) END IF grid%p_top = p_top_save ENDIF CALL monthly_interp_to_date ( grid%greenfrac , current_date , grid%vegfra , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) CALL monthly_interp_to_date ( grid%albedo12m , current_date , grid%albbck , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) CALL monthly_interp_to_date ( grid%lai12m , current_date , grid%lai , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) CALL monthly_min_max ( grid%greenfrac , grid%shdmin , grid%shdmax , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) CALL monthly_avg ( grid%greenfrac , grid%shdavg , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%vegfra(i,j) = grid%vegfra(i,j) * 100. grid%shdmax(i,j) = grid%shdmax(i,j) * 100. grid%shdmin(i,j) = grid%shdmin(i,j) * 100. grid%shdavg(i,j) = grid%shdavg(i,j) * 100. END DO END DO DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%albbck(i,j) = grid%albbck(i,j) / 100. grid%snoalb(i,j) = grid%snoalb(i,j) / 100. IF ( grid%landmask(i,j) .LT. 0.5 ) THEN grid%albbck(i,j) = 0.08 grid%snoalb(i,j) = 0.08 END IF END DO END DO IF ( ( flag_psfc .EQ. 1 ) .AND. & ( flag_soilhgt .EQ. 1 ) .AND. & ( flag_slp .EQ. 1 ) .AND. & ( .NOT. config_flags%sfcp_to_sfcp ) ) THEN WRITE(a_message,FMT='(A)') 'Using sfcprs3 to compute psfc' CALL wrf_message ( a_message ) CALL sfcprs3(grid%ght_gc, grid%p_gc, grid%ht, & grid%pslv_gc, grid%psfc, & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) ELSE IF ( ( flag_psfc .EQ. 1 ) .AND. & ( flag_soilhgt .EQ. 1 ) .AND. & ( config_flags%sfcp_to_sfcp ) ) THEN WRITE(a_message,FMT='(A)') 'Using sfcprs2 to compute psfc' CALL wrf_message ( a_message ) CALL sfcprs2(grid%t_gc, grid%qv_gc, grid%ght_gc, grid%psfc_gc, grid%ht, & grid%tavgsfc, grid%p_gc, grid%psfc, we_have_tavgsfc, & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) ELSE IF ( flag_slp .EQ. 1 ) THEN WRITE(a_message,FMT='(A)') 'Using sfcprs to compute psfc' CALL wrf_message ( a_message ) CALL sfcprs (grid%t_gc, grid%qv_gc, grid%ght_gc, grid%pslv_gc, grid%ht, & grid%tavgsfc, grid%p_gc, grid%psfc, we_have_tavgsfc, & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) ELSE WRITE(a_message,FMT='(3(A,I2),A,L1)') 'ERROR in psfc: flag_psfc = ',flag_psfc, & ', flag_soilhgt = ',flag_soilhgt , & ', flag_slp = ',flag_slp , & ', sfcp_to_sfcp = ',config_flags%sfcp_to_sfcp CALL wrf_message ( a_message ) CALL wrf_error_fatal3("",1435,& 'not enough info for a p sfc computation' ) END IF IF ( flag_psfc .NE. 1 ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%psfc_gc(i,j) = grid%psfc(i,j) grid%p_gc(i,1,j) = grid%psfc(i,j) END DO END DO END IF CALL integ_moist ( grid%qv_gc , grid%p_gc , grid%pd_gc , grid%t_gc , grid%ght_gc , grid%intq_gc , & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) IF ( flag_ptheta .EQ. 1 ) THEN DO j = jts, MIN(jte,jde-1) DO k = num_metgrid_levels-1 , 1 , -1 DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 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 grid%pdrho_gc(i,k,j) = grid%prho_gc(i,k,j) - ptemp END DO END DO END DO END IF CALL p_dts ( grid%mu0 , grid%intq_gc , grid%psfc , grid%p_top , & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) CALL p_dhs ( grid%pdhs , grid%ht , p00 , t00 , a , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IF ( grid%znw(1) .NE. 1.0 ) THEN vnest = .FALSE. DO id=1,model_config_rec%max_dom IF (model_config_rec%vert_refine_method(id) .EQ. 2) THEN vnest = .TRUE. ENDIF ENDDO IF ((model_config_rec%eta_levels(1) .NE. -1.0) .AND. (vnest)) THEN CALL wrf_debug (0, "module_initialize_real: using vert_refine_method=2, reading in eta_levels from namelist.input") ks = 0 DO id=1,grid%id ks = ks+model_config_rec%e_vert(id) ENDDO IF (ks .GT. max_eta) THEN CALL wrf_error_fatal3("",1517,& "too many vertical levels, increase max_eta in frame/module_driver_constants.F") ENDIF IF (grid%id .EQ. 1) THEN ks = 1 ke = model_config_rec%e_vert(1) ELSE id = 1 ks = 1 ke = 0 DO WHILE (grid%id .GT. id) id = id+1 ks = ks+model_config_rec%e_vert(id-1) ke = ks+model_config_rec%e_vert(id)-1 ENDDO ENDIF eta_levels(1:kde) = model_config_rec%eta_levels(ks:ke) IF (eta_levels(1) .NE. 1.0) THEN CALL wrf_error_fatal3("",1541,& "--- ERROR: the first specified eta_level is not 1.0") ENDIF IF (eta_levels(kde) .NE. 0.0) THEN CALL wrf_error_fatal3("",1545,& "--- ERROR: the last specified eta_level is not 0.0") ENDIF DO k=2,kde IF (eta_levels(k) .GT. eta_levels(k-1)) THEN CALL wrf_error_fatal3("",1550,& "--- ERROR: specified eta_levels are not uniformly decreasing from 1.0 to 0.0") ENDIF ENDDO ELSE vnest = .FALSE. DO id=1,model_config_rec%max_dom IF (model_config_rec%vert_refine_method(id) .EQ. 1) THEN vnest = .TRUE. ENDIF ENDDO IF ((vnest) .AND. (model_config_rec%eta_levels(kde+1) .NE. -1.0)) THEN write(wrf_err_message,'(A)') "--- ERROR: too many eta_levels defined in namelist.input." CALL wrf_error_fatal3("",1568,& wrf_err_message ) ELSEIF ((vnest) .AND. (model_config_rec%eta_levels(1) .NE. -1.0)) THEN CALL wrf_debug(0, "module_initialize_real: using vert_refine_method=1, reading in eta_levels for d01 from namelist.input") eta_levels(1:kde) = model_config_rec%eta_levels(1:kde) IF (eta_levels(1) .NE. 1.0) THEN CALL wrf_error_fatal3("",1576,& "--- ERROR: the first specified eta_level is not 1.0") ENDIF IF (eta_levels(kde) .NE. 0.0) THEN CALL wrf_error_fatal3("",1580,& "--- ERROR: the last specified eta_level is not 0.0") ENDIF DO k=2,kde IF (eta_levels(k) .GT. eta_levels(k-1)) THEN CALL wrf_error_fatal3("",1585,& "--- ERROR: specified eta_levels are not uniformly decreasing from 1.0 to 0.0") ENDIF ENDDO ELSE eta_levels(1:kde) = model_config_rec%eta_levels(1:kde) ENDIF ENDIF max_dz = model_config_rec%max_dz dzbot = model_config_rec%dzbot dzstretch_s = model_config_rec%dzstretch_s dzstretch_u = model_config_rec%dzstretch_u auto_levels_opt = model_config_rec%auto_levels_opt CALL compute_eta ( grid%znw , auto_levels_opt, & eta_levels , max_eta , max_dz , dzbot , dzstretch_s , dzstretch_u , & grid%p_top , g , p00 , cvpm , a , r_d , cp , & t00 , p1000mb , t0 , tiso , p_strat , a_strat , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF CALL compute_vcoord_1d_coeffs ( grid%ht, grid%etac, grid%znw, & config_flags%hybrid_opt, & r_d, g, p1000mb, & grid%p_top, grid%p00, grid%t00, grid%tlp, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte, & grid%znu, & grid%c1f, grid%c2f, grid%c3f, grid%c4f, & grid%c1h, grid%c2h, grid%c3h, grid%c4h ) IF ( config_flags%interp_theta ) THEN CALL t_to_theta ( grid%t_gc , grid%p_gc , p00 , & ids , ide , jds , jde , 1 , num_metgrid_levels , & ims , ime , jms , jme , 1 , num_metgrid_levels , & its , ite , jts , jte , 1 , num_metgrid_levels ) END IF IF ( flag_slp .EQ. 1 ) THEN CALL p_dry ( grid%mu0 , grid%znw , grid%p_top , grid%pb , want_full_levels , & grid%c3f , grid%c3h , grid%c4f , grid%c4h , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) interp_type = 2 lagrange_order = grid%lagrange_order linear_interp = grid%linear_interp lowest_lev_from_sfc = .FALSE. use_levels_below_ground = .TRUE. use_surface = .TRUE. zap_close_levels = grid%zap_close_levels force_sfc_in_vinterp = 0 t_extrap_type = grid%t_extrap_type extrap_type = 1 DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%psfc_gc(i,j) = grid%pd_gc(i,1,j) grid%pd_gc(i,1,j) = grid%pslv_gc(i,j) - ( grid%p_gc(i,1,j) - grid%pd_gc(i,1,j) ) grid%ht_gc(i,j) = grid%ght_gc(i,1,j) grid%ght_gc(i,1,j) = 0. END DO END DO ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte CALL HALO_EM_VINTERP_UV_1_sub ( grid, & config_flags, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL vert_interp ( grid%ght_gc , grid%pd_gc , grid%ph0 , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & flag_hgtmaxw , flag_hgttrop , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Z' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%pd_gc(i,1,j) = grid%psfc_gc(i,j) grid%ght_gc(i,1,j) = grid%ht_gc(i,j) END DO END DO END IF CALL p_dry ( grid%mu0 , grid%znw , grid%p_top , grid%pb , want_half_levels , & grid%c3f , grid%c3h , grid%c4f , grid%c4h , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) interp_type = grid%interp_type lagrange_order = grid%lagrange_order lowest_lev_from_sfc = grid%lowest_lev_from_sfc use_levels_below_ground = grid%use_levels_below_ground use_surface = grid%use_surface zap_close_levels = grid%zap_close_levels force_sfc_in_vinterp = grid%force_sfc_in_vinterp t_extrap_type = grid%t_extrap_type extrap_type = grid%extrap_type ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte CALL HALO_EM_VINTERP_UV_1_sub ( grid, & config_flags, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL vert_interp ( grid%rh_gc , grid%pd_gc , grid%u_1 , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IF (config_flags%use_sh_qv .and. (flag_sh .eq. 1 .or. flag_qv .eq. 1)) THEN CALL vert_interp ( grid%qv_gc , grid%pd_gc , moist(:,:,:,P_QV) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF IF ( ( config_flags%interp_theta ) .AND. ( flag_tmaxw .EQ. 1 ) ) THEN CALL t_to_theta ( grid%tmaxw , grid%pmaxw , p00 , & ids , ide , jds , jde , 1 , 1 , & ims , ime , jms , jme , 1 , 1 , & its , ite , jts , jte , 1 , 1 ) END IF IF ( ( config_flags%interp_theta ) .AND. ( flag_ttrop .EQ. 1 ) ) THEN CALL t_to_theta ( grid%ttrop , grid%ptrop , p00 , & ids , ide , jds , jde , 1 , 1 , & ims , ime , jms , jme , 1 , 1 , & its , ite , jts , jte , 1 , 1 ) END IF interp_type = 2 CALL vert_interp ( grid%t_gc , grid%pd_gc , grid%t_2 , grid%pb , & grid%tmaxw , grid%ttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & flag_tmaxw , flag_ttrop , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'T' , & interp_type , lagrange_order , t_extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) interp_type = grid%interp_type interp_type = 1 CALL vert_interp ( grid%p_gc , grid%pd_gc , grid%p , grid%pb , & grid%pmaxw , grid%ptrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & flag_pmaxw , flag_ptrop , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'T' , & interp_type , lagrange_order , t_extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) interp_type = grid%interp_type grid%v_1 = grid%t_2 IF ( config_flags%interp_theta ) THEN CALL theta_to_t ( grid%v_1 , grid%p , p00 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF IF ( .not.config_flags%use_sh_qv ) THEN IF ( config_flags%rh2qv_method .eq. 1 ) THEN CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p , moist(:,:,:,P_QV) , & config_flags%rh2qv_wrt_liquid , & config_flags%qv_max_p_safe , & config_flags%qv_max_flag , config_flags%qv_max_value , & config_flags%qv_min_p_safe , & config_flags%qv_min_flag , config_flags%qv_min_value , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte-1 ) ELSE IF ( config_flags%rh2qv_method .eq. 2 ) THEN CALL rh_to_mxrat2(grid%u_1, grid%v_1, grid%p , moist(:,:,:,P_QV) , & config_flags%rh2qv_wrt_liquid , & config_flags%qv_max_p_safe , & config_flags%qv_max_flag , config_flags%qv_max_value , & config_flags%qv_min_p_safe , & config_flags%qv_min_flag , config_flags%qv_min_value , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte-1 ) END IF END IF IF ( .NOT. config_flags%interp_theta ) THEN CALL t_to_theta ( grid%t_2 , grid%p , p00 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte-1 ) END IF num_3d_m = num_moist num_3d_s = num_scalar IF ( flag_qr .EQ. 1 ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QR ) THEN CALL vert_interp ( grid%qr_gc , grid%pd_gc , moist(:,:,:,P_QR) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( ( flag_qc .EQ. 1 ) .OR. ( flag_speccldl .EQ. 1 ) ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QC ) THEN IF ( flag_speccldl .EQ. 1 ) THEN DO j = jts, MIN(jte,jde-1) DO k = 1 , num_metgrid_levels DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%qc_gc(i,k,j) = grid%cl_gc(i,k,j) /( 1. - grid%cl_gc(i,k,j) ) END DO END DO END DO END IF CALL vert_interp ( grid%qc_gc , grid%pd_gc , moist(:,:,:,P_QC) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( ( flag_qi .EQ. 1 ) .OR. ( flag_speccldf .EQ. 1 ) ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QI ) THEN IF ( flag_speccldf .EQ. 1 ) THEN DO j = jts, MIN(jte,jde-1) DO k = 1 , num_metgrid_levels DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%qi_gc(i,k,j) = grid%cf_gc(i,k,j) /( 1. - grid%cf_gc(i,k,j) ) END DO END DO END DO END IF CALL vert_interp ( grid%qi_gc , grid%pd_gc , moist(:,:,:,P_QI) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( flag_qs .EQ. 1 ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QS ) THEN CALL vert_interp ( grid%qs_gc , grid%pd_gc , moist(:,:,:,P_QS) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( flag_qg .EQ. 1 ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QG ) THEN CALL vert_interp ( grid%qg_gc , grid%pd_gc , moist(:,:,:,P_QG) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( flag_qh .EQ. 1 ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QH ) THEN CALL vert_interp ( grid%qh_gc , grid%pd_gc , moist(:,:,:,P_QH) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( flag_qni .EQ. 1 ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNI ) THEN CALL vert_interp ( grid%qni_gc , grid%pd_gc , scalar(:,:,:,P_QNI) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( flag_qnc .EQ. 1 ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNC ) THEN CALL vert_interp ( grid%qnc_gc , grid%pd_gc , scalar(:,:,:,P_QNC) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( flag_qnr .EQ. 1 ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNR ) THEN CALL vert_interp ( grid%qnr_gc , grid%pd_gc , scalar(:,:,:,P_QNR) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( flag_qns .EQ. 1 ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNS ) THEN CALL vert_interp ( grid%qns_gc , grid%pd_gc , scalar(:,:,:,P_QNS) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( flag_qng .EQ. 1 ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNG ) THEN CALL vert_interp ( grid%qng_gc , grid%pd_gc , scalar(:,:,:,P_QNG) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF IF ( flag_qnh .EQ. 1 ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNH ) THEN CALL vert_interp ( grid%qnh_gc , grid%pd_gc , scalar(:,:,:,P_QNH) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF END DO END IF aer_init_opt = config_flags%aer_init_opt if_thompsonaero_3d: IF ((config_flags%mp_physics .EQ. THOMPSONAERO & .OR. config_flags%mp_physics .EQ. RCON_MP_SCHEME) .AND. & config_flags%wif_input_opt .GT. 0) THEN select_aer_init_opt_3d: select case (aer_init_opt) case (0) CALL wrf_debug (0 , 'COMMENT: QNWFA and QNIFA will be initialized to zero values') DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNWFA .or. im .EQ. P_QNIFA) THEN DO j = jts, MIN(jte,jde-1) DO k = kts, kte DO i = its, MIN(ite,ide-1) scalar(i,k,j,im) = 0.0 END DO END DO END DO END IF END DO case (1) CALL wrf_debug (0 , 'COMMENT: Using monthly climatology aerosols') do_pres_cl: if (flag_qnwfa_cl .EQ. 1 .and. flag_qnifa_cl .EQ. 1) then if (config_flags%num_wif_levels .EQ. num_wif_levels_default) then IF ( grid%p_wif_jan(its,config_flags%num_wif_levels/2-1,jts) - & grid%p_wif_jan(its,config_flags%num_wif_levels/2+1,jts) .LT. 0 ) THEN wif_upside_down = .TRUE. END IF DO k = 1, config_flags%num_wif_levels DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%qntemp(i, 1, j) = grid %p_wif_jan(i,k,j) grid%qntemp(i, 2, j) = grid %p_wif_feb(i,k,j) grid%qntemp(i, 3, j) = grid %p_wif_mar(i,k,j) grid%qntemp(i, 4, j) = grid %p_wif_apr(i,k,j) grid%qntemp(i, 5, j) = grid %p_wif_may(i,k,j) grid%qntemp(i, 6, j) = grid %p_wif_jun(i,k,j) grid%qntemp(i, 7, j) = grid %p_wif_jul(i,k,j) grid%qntemp(i, 8, j) = grid %p_wif_aug(i,k,j) grid%qntemp(i, 9, j) = grid %p_wif_sep(i,k,j) grid%qntemp(i,10, j) = grid %p_wif_oct(i,k,j) grid%qntemp(i,11, j) = grid %p_wif_nov(i,k,j) grid%qntemp(i,12, j) = grid %p_wif_dec(i,k,j) END DO END DO CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IF ( wif_upside_down ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid %p_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j) END DO END DO ELSE IF ( .NOT. wif_upside_down ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid %p_wif_now(i, k,j) = grid%qntemp2(i,j) END DO END DO END IF END DO else CALL wrf_error_fatal3("",2251,& 'mp_physics=28 and use_aero_icbc=.true. but wrong num_wif_levels, please set =30') end if else CALL wrf_error_fatal3("",2255,& 'mp_physics=28 and use_aero_icbc=.true. but aerosol climatology field(s) missing' ) end if do_pres_cl do_qnwfa_cl: if (flag_qnwfa_cl .EQ. 1) then DO k = 1, config_flags%num_wif_levels DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%qntemp(i, 1, j) = grid %w_wif_jan(i,k,j) grid%qntemp(i, 2, j) = grid %w_wif_feb(i,k,j) grid%qntemp(i, 3, j) = grid %w_wif_mar(i,k,j) grid%qntemp(i, 4, j) = grid %w_wif_apr(i,k,j) grid%qntemp(i, 5, j) = grid %w_wif_may(i,k,j) grid%qntemp(i, 6, j) = grid %w_wif_jun(i,k,j) grid%qntemp(i, 7, j) = grid %w_wif_jul(i,k,j) grid%qntemp(i, 8, j) = grid %w_wif_aug(i,k,j) grid%qntemp(i, 9, j) = grid %w_wif_sep(i,k,j) grid%qntemp(i,10, j) = grid %w_wif_oct(i,k,j) grid%qntemp(i,11, j) = grid %w_wif_nov(i,k,j) grid%qntemp(i,12, j) = grid %w_wif_dec(i,k,j) END DO END DO CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IF ( wif_upside_down ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid %w_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j) END DO END DO ELSE IF ( .NOT. wif_upside_down ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid %w_wif_now(i, k,j) = grid%qntemp2(i,j) END DO END DO END IF END DO CALL wrf_debug (0 , 'Vertically-interpolating QNWFA climatology from WPS data to fill scalar') CALL vert_interp ( grid %w_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnwfa) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & config_flags%num_wif_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) else CALL wrf_error_fatal3("",2312,& 'mp_physics=28 but there is not QNWFA aerosol information from climatology' ) end if do_qnwfa_cl do_qnifa_cl: if (flag_qnifa_cl .EQ. 1) then DO k = 1, config_flags%num_wif_levels WRITE(a_message,*) ' transferring each K-level ', k, ' to QNIFA, sample Jan data, ', grid %i_wif_jan(its,k,jts) CALL wrf_debug ( 1 , a_message) DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%qntemp(i, 1, j) = grid %i_wif_jan(i,k,j) grid%qntemp(i, 2, j) = grid %i_wif_feb(i,k,j) grid%qntemp(i, 3, j) = grid %i_wif_mar(i,k,j) grid%qntemp(i, 4, j) = grid %i_wif_apr(i,k,j) grid%qntemp(i, 5, j) = grid %i_wif_may(i,k,j) grid%qntemp(i, 6, j) = grid %i_wif_jun(i,k,j) grid%qntemp(i, 7, j) = grid %i_wif_jul(i,k,j) grid%qntemp(i, 8, j) = grid %i_wif_aug(i,k,j) grid%qntemp(i, 9, j) = grid %i_wif_sep(i,k,j) grid%qntemp(i,10, j) = grid %i_wif_oct(i,k,j) grid%qntemp(i,11, j) = grid %i_wif_nov(i,k,j) grid%qntemp(i,12, j) = grid %i_wif_dec(i,k,j) END DO END DO IF ( k .EQ. 1 ) THEN WRITE(a_message,*) ' QNIFA (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts) CALL wrf_debug ( 1 , a_message) END IF CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IF ( k .eq. 1 ) THEN write(a_message,*) ' QNIFA (now) ', grid%qntemp2(its,jts) CALL wrf_debug ( 1 , a_message) END IF IF ( wif_upside_down ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid %i_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j) END DO END DO ELSE IF ( .NOT. wif_upside_down ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid %i_wif_now(i, k,j) = grid%qntemp2(i,j) END DO END DO END IF END DO CALL wrf_debug (0 , 'Vertically-interpolating QNIFA climatology from WPS data to fill scalar') CALL vert_interp ( grid %i_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnifa) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & config_flags%num_wif_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) else CALL wrf_error_fatal3("",2379,& 'mp_physics=28 but there is not QNIFA aerosol information from climatology' ) end if do_qnifa_cl if (config_flags%wif_input_opt .EQ. 2) then do_qnbca_cl: if (flag_qnbca_cl .EQ. 1) then DO k = 1, config_flags%num_wif_levels WRITE(a_message,*) ' transferring each K-level ', k, ' to QNBCA, sample Jan data, ', grid %b_wif_jan(its,k,jts) CALL wrf_debug ( 1 , a_message) DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%qntemp(i, 1, j) = grid %b_wif_jan(i,k,j) grid%qntemp(i, 2, j) = grid %b_wif_feb(i,k,j) grid%qntemp(i, 3, j) = grid %b_wif_mar(i,k,j) grid%qntemp(i, 4, j) = grid %b_wif_apr(i,k,j) grid%qntemp(i, 5, j) = grid %b_wif_may(i,k,j) grid%qntemp(i, 6, j) = grid %b_wif_jun(i,k,j) grid%qntemp(i, 7, j) = grid %b_wif_jul(i,k,j) grid%qntemp(i, 8, j) = grid %b_wif_aug(i,k,j) grid%qntemp(i, 9, j) = grid %b_wif_sep(i,k,j) grid%qntemp(i,10, j) = grid %b_wif_oct(i,k,j) grid%qntemp(i,11, j) = grid %b_wif_nov(i,k,j) grid%qntemp(i,12, j) = grid %b_wif_dec(i,k,j) END DO END DO IF ( k .EQ. 1 ) THEN WRITE(a_message,*) ' QNBCA (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts) CALL wrf_debug ( 1 , a_message) END IF CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IF ( k .eq. 1 ) THEN write(a_message,*) ' QNBCA (now) ', grid%qntemp2(its,jts) CALL wrf_debug ( 1 , a_message) END IF IF ( wif_upside_down ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid %b_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j) END DO END DO ELSE IF ( .NOT. wif_upside_down ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid %b_wif_now(i, k,j) = grid%qntemp2(i,j) END DO END DO END IF END DO CALL wrf_debug (0 , 'Vertically-interpolating QNBCA climatology from WPS data to fill scalar') CALL vert_interp ( grid %b_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnbca) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & config_flags%num_wif_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) else CALL wrf_error_fatal3("",2447,& 'mp_physics=28 and wif_input_opt=2 but there is not QNBCA aerosol information from climatology' ) end if do_qnbca_cl end if case (2) CALL wrf_debug (0 , 'COMMENT: Using first guess aerosols') do_qnwfa: if (flag_qnwfa .EQ. 1) then if (flag_p_wif .EQ. 1 ) then CALL wrf_debug (0 , 'Vertically-interpolating QNWFA first guess from WPS data to fill scalar using native pressure field') CALL wrf_debug (0 , 'COMMENT: BE SURE num_wif_levels IN NAMELIST EQUALS num_wif_levels IN MET_EM FILES!') CALL vert_interp ( grid%qnwfa_gc , grid%p_wif_gc , scalar(:,:,:,P_QNWFA) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & config_flags%num_wif_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) else if (config_flags%num_wif_levels .EQ. num_metgrid_levels) then CALL wrf_debug (0 , 'Vertically-interpolating QNWFA first guess from WPS data to fill scalar using metgrid pressure field') CALL vert_interp ( grid%qnwfa_gc , grid%pd_gc , scalar(:,:,:,P_QNWFA) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & config_flags%num_wif_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) else CALL wrf_error_fatal3("",2491,& 'num_wif_levels not equal to num_metgrid_levels') end if end if else CALL wrf_error_fatal3("",2496,& 'mp_physics=28 but there is not QNWFA aerosol information from first guess' ) end if do_qnwfa do_qnifa: if (flag_qnifa .EQ. 1) then if (flag_p_wif .EQ. 1) then CALL wrf_debug (0 , 'Vertically-interpolating QNIFA first guess from WPS data to fill scalar using native pressure field') CALL wrf_debug (0 , 'COMMENT: BE SURE num_wif_levels IN NAMELIST EQUALS num_wif_levels IN MET_EM FILES!') CALL vert_interp ( grid%qnifa_gc , grid%p_wif_gc , scalar(:,:,:,P_QNIFA) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & config_flags%num_wif_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) else if (config_flags%num_wif_levels .EQ. num_metgrid_levels) then CALL wrf_debug (0 , 'Vertically-interpolating QNIFA first guess from WPS data to fill scalar using metgrid pressure field') CALL vert_interp ( grid%qnifa_gc , grid%pd_gc , scalar(:,:,:,P_QNIFA) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & config_flags%num_wif_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) else CALL wrf_error_fatal3("",2535,& 'num_qnifa_levels not equal to num_metgrid_levels') end if end if else CALL wrf_error_fatal3("",2540,& 'mp_physics=28 but there is not QNIFA aerosol information from first guess' ) end if do_qnifa if (config_flags%wif_input_opt .EQ. 2) then do_qnbca: if (flag_qnbca .EQ. 1) then if (flag_p_wif .EQ. 1) then CALL wrf_debug (0 , 'Vertically-interpolating QNBCA first guess from WPS data to fill scalar using native pressure field') CALL wrf_debug (0 , 'COMMENT: BE SURE num_wif_levels IN NAMELIST EQUALS num_wif_levels IN MET_EM FILES!') CALL vert_interp ( grid%qnbca_gc , grid%p_wif_gc , scalar(:,:,:,P_QNBCA) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & config_flags%num_wif_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) else if (config_flags%num_wif_levels .EQ. num_metgrid_levels) then CALL wrf_debug (0 , 'Vertically-interpolating QNBCA first guess from WPS data to fill scalar using metgrid pressure field') CALL vert_interp ( grid%qnbca_gc , grid%pd_gc , scalar(:,:,:,P_QNBCA) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & config_flags%num_wif_levels , 'Q' , & interp_type , linear_interp , extrap_type , & .false. , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) else CALL wrf_error_fatal3("",2580,& 'num_qnifa_levels not equal to num_metgrid_levels') end if end if else CALL wrf_error_fatal3("",2585,& 'mp_physics=28 and wif_input_opt=2 but there is not QNBCA aerosol information from first guess' ) end if do_qnbca end if case default CALL wrf_debug (0 , 'aer_init_opt = ', aer_init_opt) CALL wrf_error_fatal3("",2593,& 'Aerosol forcing option does not exist for mp_physics=28' ) end select select_aer_init_opt_3d ELSE IF ((config_flags%mp_physics .EQ. THOMPSONAERO & .OR. config_flags%mp_physics .EQ. RCON_MP_SCHEME) .and. & config_flags%wif_input_opt .EQ. 0 ) THEN CALL wrf_error_fatal3("",2601,& 'wif_input_opt=0 but mp_physics=28 or mp_physics=29' ) END IF if_thompsonaero_3d IF ( flag_ptheta .EQ. 1 ) THEN DO j = jts, MIN(jte,jde-1) DO k = 1 , num_metgrid_levels DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%pd_gc(i,k,j) = grid%prho_gc(i,k,j) END DO END DO END DO END IF ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte CALL HALO_EM_VINTERP_UV_1_sub ( grid, & config_flags, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL vert_interp ( grid%u_gc , grid%pd_gc , grid%u_2 , grid%pb , & grid%umaxw , grid%utrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & flag_umaxw , flag_utrop , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'U' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) CALL vert_interp ( grid%v_gc , grid%pd_gc , grid%v_2 , grid%pb , & grid%vmaxw , grid%vtrop , grid%pmaxw , grid%ptrop , & grid%pmaxwnn , grid%ptropnn , & flag_vmaxw , flag_vtrop , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & num_metgrid_levels , 'V' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) END IF num_veg_cat = SIZE ( grid%landusef , DIM=2 ) CALL nl_get_iswater ( grid%id , grid%iswater ) CALL nl_get_islake ( grid%id , grid%islake ) IF ( grid%islake < 0 ) THEN grid%lakeflag=0 CALL wrf_debug ( 0 , 'Old data, no inland lake information') DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ( ( grid%landusef(i,grid%iswater,j) >= 0.5 ) .OR. ( grid%lu_index(i,j) == grid%iswater ) ) .AND. & ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) ) THEN IF ( we_have_tavgsfc ) THEN grid%sst(i,j) = grid%tavgsfc(i,j) END IF IF ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) THEN grid%sst(i,j) = grid%tsk(i,j) END IF IF ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) THEN grid%sst(i,j) = grid%t2(i,j) END IF END IF END DO END DO ELSE grid%lakeflag=1 IF ( we_have_tavgsfc ) THEN CALL wrf_debug ( 0 , 'Using inland lakes with average surface temperature') DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ( grid%landusef(i,grid%islake,j) >= 0.5 ) .OR. ( grid%lu_index(i,j) == grid%islake ) ) THEN grid%sst(i,j) = grid%tavgsfc(i,j) grid%tsk(i,j) = grid%tavgsfc(i,j) END IF IF ( ( grid%sst(i,j) .LT. 150 ) .OR. ( grid%sst(i,j) .GT. 400 ) ) THEN grid%sst(i,j) = grid%t2(i,j) END IF END DO END DO ELSE CALL wrf_debug ( 0 , 'No average surface temperature for use with inland lakes') END IF DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%landusef(i,grid%iswater,j) = grid%landusef(i,grid%iswater,j) + & grid%landusef(i,grid%islake,j) grid%landusef(i,grid%islake,j) = 0. END DO END DO IF ( config_flags%surface_input_source .EQ. 3 ) THEN DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( grid%lu_index(i,j) .EQ. grid%islake ) THEN grid%lu_index(i,j) = grid%iswater END IF END DO END DO END IF END IF DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%tsk_save(i,j) = grid%tsk(i,j) END DO END DO DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. & ( grid%sst(i,j) .GT. 170. ) .AND. ( grid%sst(i,j) .LT. 400. ) ) THEN grid%tsk(i,j) = grid%sst(i,j) ENDIF END DO END DO DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( grid%snow(i,j) .GE. 10. ) then grid%snowc(i,j) = 1. ELSE grid%snowc(i,j) = 0.0 END IF END DO END DO grid%ifndsnowh = flag_snowh IF (num_sw_levels_input .GE. 1) THEN grid%ifndsoilw = 1 ELSE grid%ifndsoilw = 0 END IF IF ( config_flags%seaice_albedo_opt == 2 ) THEN grid%ifndalbsi = flag_albsi ELSE grid%ifndalbsi = 0 ENDIF IF ( config_flags%seaice_snowdepth_opt == 1 ) THEN grid%ifndsnowsi = flag_snowsi ELSE grid%ifndsnowsi = 0 ENDIF IF ( config_flags%seaice_thickness_opt == 1 ) THEN grid%ifndicedepth = flag_icedepth ELSE grid%ifndicedepth = 0 ENDIF CALL nl_get_mminlu ( grid%id , mminlu ) write(a_message,*) 'MMINLU = ',trim(mminlu) CALL wrf_debug ( 1 , a_message ) write(a_message,*) 'sf_surface_physics = ',model_config_rec%sf_surface_physics(grid%id) CALL wrf_debug ( 1, a_message ) probs_with_nlcd : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) CASE ( RUCLSMSCHEME, NOAHMPSCHEME, CLMSCHEME, SSIBSCHEME ) IF ( TRIM(mminlu) .EQ. 'NLCD40' ) THEN CALL wrf_message ( 'NLCD40 data may be used with SLABSCHEME, LSMSCHEME, PXLSMSCHEME' ) CALL wrf_message ( 'Re-run geogrid and choose a different land cover source, or select a different sf_surface_physics option' ) CALL wrf_error_fatal3("",2832,& 'NLCD40 data may not be used with: RUCLSMSCHEME, NOAHMPSCHEME, CLMSCHEME, SSIBSCHEME' ) END IF CASE ( SLABSCHEME, LSMSCHEME, PXLSMSCHEME ) CALL wrf_debug ( 1, 'NLCD40 being used with an OK scheme' ) END SELECT probs_with_nlcd enough_data : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) CASE ( LSMSCHEME, NOAHMPSCHEME ) IF ( num_st_levels_input .LT. 2 ) THEN CALL wrf_error_fatal3("",2847,& 'Not enough soil temperature data for Noah LSM scheme.') END IF CASE (RUCLSMSCHEME) IF ( num_st_levels_input .LT. 2 ) THEN CALL wrf_error_fatal3("",2853,& 'Not enough soil temperature data for RUC LSM scheme.') END IF CASE (PXLSMSCHEME) IF ( num_st_levels_input .LT. 2 ) THEN CALL wrf_error_fatal3("",2859,& 'Not enough soil temperature data for P-X LSM scheme.') END IF CASE (CLMSCHEME) IF ( num_st_levels_input .LT. 2 ) THEN CALL wrf_error_fatal3("",2864,& 'Not enough soil temperature data for CLM LSM scheme.') END IF CASE (SSIBSCHEME) IF ( num_st_levels_input .LT. 2 ) THEN CALL wrf_error_fatal3("",2870,& 'Not enough soil temperature data for SSIB LSM scheme.') END IF IF ( eta_levels(2) .GT. 0.982 ) THEN CALL wrf_error_fatal3("",2874,& 'The first two eta levels are too shallow for SSIB LSM scheme.') END IF END SELECT enough_data interpolate_soil_tmw : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) CASE ( SLABSCHEME,LSMSCHEME,NOAHMPSCHEME,RUCLSMSCHEME,PXLSMSCHEME,CLMSCHEME,SSIBSCHEME ) CALL process_soil_real ( grid%tsk , grid%tmn , grid%tavgsfc, & grid%landmask , grid%sst , grid%ht, grid%toposoil, & st_input , sm_input , sw_input , & st_levels_input , sm_levels_input , sw_levels_input , & grid%zs , grid%dzs , model_config_rec%flag_sm_adj , & grid%tslb , grid%smois , grid%sh2o , & flag_sst , flag_tavgsfc, flag_soilhgt, & flag_soil_layers, flag_soil_levels, & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte , & model_config_rec%sf_surface_physics(grid%id) , & model_config_rec%num_soil_layers , & model_config_rec%real_data_init_type , & num_st_levels_input , num_sm_levels_input , num_sw_levels_input , & num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc ) END SELECT interpolate_soil_tmw IF ( any_valid_points ) THEN IF ( config_flags%surface_input_source .EQ. 1 ) THEN grid%vegcat (its,jts) = 0 grid%soilcat(its,jts) = 0 num_veg_cat = SIZE ( grid%landusef , DIM=2 ) num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 ) num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 ) CALL process_percent_cat_new ( grid%landmask , & grid%landusef , grid%soilctop , grid%soilcbot , & grid%isltyp , grid%ivgtyp , & num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte , & model_config_rec%iswater(grid%id) ) DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%vegcat(i,j) = grid%ivgtyp(i,j) grid%soilcat(i,j) = grid%isltyp(i,j) END DO END DO ELSE IF ( config_flags%surface_input_source .EQ. 2 ) THEN IF ( grid%soilcat(i_valid,j_valid) .GT. 0.5 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%isltyp(i,j) = NINT( grid%soilcat(i,j) ) END DO END DO END IF IF ( grid%vegcat(i_valid,j_valid) .GT. 0.5 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%ivgtyp(i,j) = NINT( grid%vegcat(i,j) ) END DO END DO END IF ELSE IF ( config_flags%surface_input_source .EQ. 3 ) THEN IF ( grid%sct_dom_gc(i_valid,j_valid) .GT. 0.5 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%isltyp(i,j) = NINT( grid%sct_dom_gc(i,j) ) grid%soilcat(i,j) = grid%isltyp(i,j) END DO END DO ELSE WRITE ( a_message , * ) 'You have set surface_input_source = 3,'// & ' but your geogrid data does not have valid dominant soil data.' CALL wrf_error_fatal3("",2976,& a_message ) END IF IF ( grid%lu_index(i_valid,j_valid) .GT. 0.5 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%ivgtyp(i,j) = NINT( grid%lu_index(i,j) ) grid%vegcat(i,j) = grid%ivgtyp(i,j) END DO END DO ELSE WRITE ( a_message , * ) 'You have set surface_input_source = 3,'//& ' but your geogrid data does not have valid dominant land use data.' CALL wrf_error_fatal3("",2990,& a_message ) END IF iforce = 0 change_soil = 0 change_soilw = 0 DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( grid%landmask(i,j) .GT. 0.5 .AND. grid%isltyp(i,j) .EQ. grid%isoilwater ) THEN grid%isltyp(i,j) = config_flags%default_soiltype change_soilw = change_soilw + 1 iforce = iforce + 1 ELSE IF ( grid%landmask(i,j) .LT. 0.5 .AND. grid%isltyp(i,j) .NE. grid%isoilwater ) THEN grid%isltyp(i,j) = grid%isoilwater change_soil = change_soil + 1 iforce = iforce + 1 END IF END DO END DO IF ( change_soilw .GT. 0 .OR. change_soil .GT. 0 ) THEN IF (config_flags%default_soiltype == 8) THEN WRITE(a_message,FMT='(A,I4,A,I6)' ) & 'forcing artificial silty clay loam at ',iforce,' points, out of ',& (MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1) ELSE WRITE(a_message,FMT='(A,I4,A,I4,A,I6)' ) & 'forcing soil type to the user defined default category (',config_flags%default_soiltype,& ') at ',iforce,' points, out of ',& (MIN(ide-1,ite)-its+1)*(MIN(jde-1,jte)-jts+1) ENDIF CALL wrf_debug(0,a_message) END IF END IF distributed_aerodynamics_if: IF (config_flags%sf_urban_physics == 1 .AND. config_flags%slucm_distributed_drag) THEN CALL nl_get_isurban ( grid%id , grid%isurban ) DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF (grid%landusef(i, grid%isurban, j) > 0) THEN grid%frc_urb2d(i, j) = MAX(0.1, MIN(0.9, 1 - grid%shdavg(i, j) / 100.)) END IF END DO END DO ELSE IF ( ( config_flags%sf_urban_physics == 1 ) .OR. ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( MMINLU == 'NLCD40' .OR. MMINLU == 'MODIFIED_IGBP_MODIS_NOAH') THEN IF ( grid%FRC_URB2D(i,j) .GE. 0.5 .AND. & (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 ELSE IF ( MMINLU == "USGS" ) THEN IF ( grid%FRC_URB2D(i,j) .GE. 0.5 .AND. & grid%ivgtyp(i,j).NE.1 .AND. grid%ivgtyp(i,j).LT.30) grid%ivgtyp(i,j)=1 ENDIF IF ( grid%FRC_URB2D(i,j) == 0. ) THEN IF ( (MMINLU == 'NLCD40' .OR. MMINLU == 'MODIFIED_IGBP_MODIS_NOAH') .AND. & (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 IF ( MMINLU == 'USGS' .AND. grid%ivgtyp(i,j)==1 ) grid%FRC_URB2D(i,j) = 0.9 ENDIF IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%LP_URB2D(i,j) = grid%URB_PARAM(i,91,j) grid%LB_URB2D(i,j) = grid%URB_PARAM(i,95,j) grid%HGT_URB2D(i,j) = grid%URB_PARAM(i,94,j) END DO END DO ENDIF IF ( ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE DO k = 1, 15 grid%HI_URB2D(i,k,j) = grid%URB_PARAM(i,k+117,j) END DO END DO END DO ENDIF DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( config_flags%sf_urban_physics==1 ) THEN grid%MH_URB2D(i,j) = grid%URB_PARAM(i,92,j) grid%STDH_URB2D(i,j) = grid%URB_PARAM(i,93,j) ENDIF END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE DO k = 1, 4 IF ( config_flags%sf_urban_physics==1 ) THEN grid%LF_URB2D(i,k,j) = grid%URB_PARAM(i,k+95,j) ENDIF END DO END DO END DO END IF distributed_aerodynamics_if END IF num_veg_cat = SIZE ( grid%landusef , DIM=2 ) num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 ) num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 ) CALL nl_get_seaice_threshold ( grid%id , grid%seaice_threshold ) CALL nl_get_isice ( grid%id , grid%isice ) CALL nl_get_iswater ( grid%id , grid%iswater ) CALL adjust_for_seaice_pre ( grid%xice , grid%landmask , grid%tsk , grid%ivgtyp , grid%vegcat , grid%lu_index , & grid%xland , grid%landusef , grid%isltyp , grid%soilcat , grid%soilctop , & grid%soilcbot , grid%tmn , & grid%seaice_threshold , & config_flags%fractional_seaice, & num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & grid%iswater , grid%isice , & model_config_rec%sf_surface_physics(grid%id) , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%lu_index(i,j) = grid%ivgtyp(i,j) IF ( grid%lu_index(i,j) .NE. model_config_rec%iswater(grid%id) ) THEN grid%landmask(i,j) = 1 grid%xland(i,j) = 1 ELSE grid%landmask(i,j) = 0 grid%xland(i,j) = 2 END IF END DO END DO fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) CASE ( SLABSCHEME , LSMSCHEME , NOAHMPSCHEME , RUCLSMSCHEME, PXLSMSCHEME,CLMSCHEME, CTSMSCHEME, SSIBSCHEME ) DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) .AND. & ( grid%sst(i,j) .GT. 170. ) .AND. ( grid%sst(i,j) .LT. 400. ) ) THEN grid%tmn(i,j) = grid%sst(i,j) grid%tsk(i,j) = grid%sst(i,j) ELSE IF ( grid%landmask(i,j) .LT. 0.5 ) THEN grid%tmn(i,j) = grid%tsk(i,j) END IF END DO END DO END SELECT fix_tsk_tmn IF ( internal_time_loop .NE. 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( grid%tsk(i,j) .LT. 170 .or. grid%tsk(i,j) .GT. 400. ) THEN grid%tsk(i,j) = grid%t_2(i,1,j) END IF END DO END DO ELSE DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( grid%tsk(i,j) .LT. 170 .or. grid%tsk(i,j) .GT. 400. ) THEN print *,'error in the grid%tsk' print *,'i,j=',i,j print *,'grid%landmask=',grid%landmask(i,j) print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j) if(grid%tmn(i,j).gt.170. .and. grid%tmn(i,j).lt.400.)then grid%tsk(i,j)=grid%tmn(i,j) else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then grid%tsk(i,j)=grid%sst(i,j) else CALL wrf_error_fatal3("",3185,& 'grid%tsk unreasonable' ) end if END IF END DO END DO END IF DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ( ( grid%tmn(i,j) .LT. 170. ) .OR. ( grid%tmn(i,j) .GT. 400. ) ) & .AND. ( grid%landmask(i,j) .GT. 0.5 ) ) THEN IF ( ( model_config_rec%sf_surface_physics(grid%id) .NE. LSMSCHEME ) .and. & ( model_config_rec%sf_surface_physics(grid%id) .NE. NOAHMPSCHEME ) ) THEN print *,'error in the grid%tmn' print *,'i,j=',i,j print *,'grid%landmask=',grid%landmask(i,j) print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j) END IF if(grid%tsk(i,j).gt.170. .and. grid%tsk(i,j).lt.400.)then grid%tmn(i,j)=grid%tsk(i,j) else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then grid%tmn(i,j)=grid%sst(i,j) else CALL wrf_error_fatal3("",3213,& 'grid%tmn unreasonable' ) endif END IF END DO END DO lqmi(1:num_soil_top_cat) = & (/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, & 0.089, 0.095, 0.10, 0.070, 0.068, 0.078, 0.0, & 0.004, 0.065 /) IF ( flag_um_soil == 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) grid%smois(i,:,j)=grid%smois(i,:,j)+lqmi(grid%isltyp(i,j)) END DO END DO END IF IF ( domain_ClockIsStartTime(grid) ) THEN account_for_zero_soil_moisture : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) CASE ( LSMSCHEME , NOAHMPSCHEME ) iicount = 0 IF ( flag_soil_layers == 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. & ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then print *,'Noah -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) iicount = iicount + 1 grid%smois(i,:,j) = 0.005 END IF END DO END DO IF ( iicount .GT. 0 ) THEN print *,'Noah -> Noah: total number of small soil moisture locations = ',iicount END IF ELSE IF ( flag_soil_levels == 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) , 0.005 ) END DO END DO DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. & ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then print *,'RUC -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) iicount = iicount + 1 grid%smois(i,:,j) = 0.005 END IF END DO END DO IF ( iicount .GT. 0 ) THEN print *,'RUC -> Noah: total number of small soil moisture locations = ',iicount END IF END IF CASE ( RUCLSMSCHEME ) iicount = 0 IF ( flag_soil_layers == 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) , 0.005 ) END DO END DO ELSE IF ( flag_soil_levels == 1 ) THEN END IF CASE ( PXLSMSCHEME ) iicount = 0 IF ( flag_soil_layers == 1 ) THEN ELSE IF ( flag_soil_levels == 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) , 0.005 ) END DO END DO END IF CASE ( CLMSCHEME ) iicount = 0 IF ( flag_soil_layers == 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. & ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then print *,'CLM -> CLM: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) iicount = iicount + 1 grid%smois(i,:,j) = 0.005 END IF END DO END DO IF ( iicount .GT. 0 ) THEN print *,'CLM -> CLM: total number of small soil moisture locations = ',iicount END IF ELSE IF ( flag_soil_levels == 1 ) THEN DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) + lqmi(grid%isltyp(i,j)) , 0.005 ) END DO END DO DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( (grid%landmask(i,j).gt.0.5) .and. ( grid%tslb(i,1,j) .gt. 170 ) .and. & ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then print *,'CLM -> CLM: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) iicount = iicount + 1 grid%smois(i,:,j) = 0.005 END IF END DO END DO IF ( iicount .GT. 0 ) THEN print *,'CLM -> CLM: total number of small soil moisture locations = ',iicount END IF END IF END SELECT account_for_zero_soil_moisture END IF IF ( internal_time_loop .NE. 1 ) THEN DO j = jts, MIN(jde-1,jte) DO ns = 1 , model_config_rec%num_soil_layers DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( grid%tslb(i,ns,j) .LT. 170 .or. grid%tslb(i,ns,j) .GT. 400. ) THEN grid%tslb(i,ns,j) = grid%t_2(i,1,j) grid%smois(i,ns,j) = 0.3 END IF END DO END DO END DO ELSE DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ( ( grid%tslb(i,1,j) .LT. 170. ) .OR. ( grid%tslb(i,1,j) .GT. 400. ) ) .AND. & ( grid%landmask(i,j) .GT. 0.5 ) ) THEN IF ( ( model_config_rec%sf_surface_physics(grid%id) .NE. LSMSCHEME ) .AND. & ( model_config_rec%sf_surface_physics(grid%id) .NE. NOAHMPSCHEME ) .AND. & ( model_config_rec%sf_surface_physics(grid%id) .NE. RUCLSMSCHEME ).AND. & ( model_config_rec%sf_surface_physics(grid%id) .NE. SSIBSCHEME ).AND. & ( model_config_rec%sf_surface_physics(grid%id) .NE. CLMSCHEME ).AND. & ( model_config_rec%sf_surface_physics(grid%id) .NE. CTSMSCHEME ).AND. & ( model_config_rec%sf_surface_physics(grid%id) .NE. PXLSMSCHEME ) ) THEN print *,'error in the grid%tslb' print *,'i,j=',i,j print *,'grid%landmask=',grid%landmask(i,j) print *,'grid%tsk, grid%sst, grid%tmn=',grid%tsk(i,j),grid%sst(i,j),grid%tmn(i,j) print *,'grid%tslb = ',grid%tslb(i,:,j) print *,'old grid%smois = ',grid%smois(i,:,j) grid%smois(i,1,j) = 0.3 grid%smois(i,2,j) = 0.3 grid%smois(i,3,j) = 0.3 grid%smois(i,4,j) = 0.3 END IF IF ( (grid%tsk(i,j).GT.170. .AND. grid%tsk(i,j).LT.400.) .AND. & (grid%tmn(i,j).GT.170. .AND. grid%tmn(i,j).LT.400.) ) THEN fake_soil_temp : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) CASE ( SLABSCHEME ) DO ns = 1 , model_config_rec%num_soil_layers grid%tslb(i,ns,j) = ( grid%tsk(i,j)*(3.0 - grid%zs(ns)) + & grid%tmn(i,j)*(0.0 - grid%zs(ns)) ) /(3.0 - 0.0) END DO CASE ( LSMSCHEME , NOAHMPSCHEME , RUCLSMSCHEME, PXLSMSCHEME,CLMSCHEME, CTSMSCHEME, SSIBSCHEME ) DO ns = 1 , model_config_rec%num_soil_layers grid%tslb(i,ns,j) = ( grid%tsk(i,j)*(3.0 - grid%zs(ns)) + & grid%tmn(i,j)*(0.0 - grid%zs(ns)) ) /(3.0 - 0.0) END DO END SELECT fake_soil_temp else if(grid%tsk(i,j).gt.170. .and. grid%tsk(i,j).lt.400.)then CALL wrf_error_fatal3("",3455,& 'grid%tslb unreasonable 1' ) DO ns = 1 , model_config_rec%num_soil_layers grid%tslb(i,ns,j)=grid%tsk(i,j) END DO else if(grid%sst(i,j).gt.170. .and. grid%sst(i,j).lt.400.)then CALL wrf_error_fatal3("",3461,& 'grid%tslb unreasonable 2' ) DO ns = 1 , model_config_rec%num_soil_layers grid%tslb(i,ns,j)=grid%sst(i,j) END DO else if(grid%tmn(i,j).gt.170. .and. grid%tmn(i,j).lt.400.)then CALL wrf_error_fatal3("",3467,& 'grid%tslb unreasonable 3' ) DO ns = 1 , model_config_rec%num_soil_layers grid%tslb(i,ns,j)=grid%tmn(i,j) END DO else CALL wrf_error_fatal3("",3473,& 'grid%tslb unreasonable 4' ) endif END IF END DO END DO END IF num_veg_cat = SIZE ( grid%landusef , DIM=2 ) num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 ) num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 ) CALL nl_get_seaice_threshold ( grid%id , grid%seaice_threshold ) CALL nl_get_isice ( grid%id , grid%isice ) CALL nl_get_iswater ( grid%id , grid%iswater ) CALL adjust_for_seaice_post ( grid%xice , grid%landmask , grid%tsk , grid%tsk_save , & grid%ivgtyp , grid%vegcat , grid%lu_index , & grid%xland , grid%landusef , grid%isltyp , grid%soilcat , & grid%soilctop , & grid%soilcbot , grid%tmn , grid%vegfra , & grid%tslb , grid%smois , grid%sh2o , & grid%seaice_threshold , & grid%sst,flag_sst, & config_flags%fractional_seaice, & num_veg_cat , num_soil_top_cat , num_soil_bot_cat , & model_config_rec%num_soil_layers , & grid%iswater , grid%isice , & model_config_rec%sf_surface_physics(grid%id) , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) oops1=0 oops2=0 DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. & ( grid%ivgtyp(i,j) .NE. config_flags%iswater .OR. grid%isltyp(i,j) .NE. 14 ) ) .OR. & ( ( grid%landmask(i,j) .GT. 0.5 ) .AND. & ( grid%ivgtyp(i,j) .EQ. config_flags%iswater .OR. grid%isltyp(i,j) .EQ. 14 ) ) ) THEN IF ( grid%tslb(i,1,j) .GT. 1. ) THEN oops1=oops1+1 grid%ivgtyp(i,j) = 5 grid%isltyp(i,j) = 8 grid%landmask(i,j) = 1 grid%xland(i,j) = 1 ELSE IF ( grid%sst(i,j) .GT. 1. ) THEN oops2=oops2+1 grid%ivgtyp(i,j) = config_flags%iswater grid%isltyp(i,j) = 14 grid%landmask(i,j) = 0 grid%xland(i,j) = 2 ELSE print *,'the grid%landmask and soil/veg cats do not match' print *,'i,j=',i,j print *,'grid%landmask=',grid%landmask(i,j) print *,'grid%ivgtyp=',grid%ivgtyp(i,j) print *,'grid%isltyp=',grid%isltyp(i,j) print *,'iswater=', config_flags%iswater print *,'grid%tslb=',grid%tslb(i,:,j) print *,'grid%sst=',grid%sst(i,j) CALL wrf_error_fatal3("",3539,& 'mismatch_landmask_ivgtyp' ) END IF END IF END DO END DO if (oops1.gt.0) then print *,'points artificially set to land : ',oops1 endif if(oops2.gt.0) then print *,'points artificially set to water: ',oops2 endif DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( flag_sst .NE. 1 ) THEN grid%sst(i,j) = grid%tsk(i,j) ENDIF END DO END DO DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( grid%ivgtyp(i,j) .EQ. config_flags%isice) THEN grid%snoalb(i,j) = 0.75 ENDIF END DO END DO were_bad = .false. IF ( ( (grid%znw(1).LT.(1-1.E-5) ) .OR. ( grid%znw(1).GT.(1+1.E-5) ) ).AND. & ( (grid%znw(1).LT.(0-1.E-5) ) .OR. ( grid%znw(1).GT.(0+1.E-5) ) ) ) THEN were_bad = .true. print *,'Your grid%znw input values are probably half-levels. ' print *,grid%znw print *,'WRF expects grid%znw values to be full levels. ' print *,'Adjusting now to full levels...' IF (grid%znw(1).LT.0) THEN grid%znw(1)=0 END IF DO k=2,kde grid%znw(k)=2*grid%znw(k)-grid%znw(k-1) END DO END IF IF ( ( ( grid%znw(1) .LT. (1-1.E-5) ) .OR. ( grid%znw(1) .GT. (1+1.E-5) ) ).AND. & ( ( grid%znw(1) .LT. (0-1.E-5) ) .OR. ( grid%znw(1) .GT. (0+1.E-5) ) ) ) THEN print *,'The input grid%znw height values were half-levels or erroneous. ' print *,'Attempts to treat the values as half-levels and change them ' print *,'to valid full levels failed.' CALL wrf_error_fatal3("",3603,& "bad grid%znw values from input files") ELSE IF ( were_bad ) THEN print *,'...adjusted. grid%znw array now contains full eta level values. ' ENDIF IF ( grid%znw(1) .LT. grid%znw(kde) ) THEN DO k=1, kde/2 hold_znw = grid%znw(k) grid%znw(k)=grid%znw(kde+1-k) grid%znw(kde+1-k)=hold_znw END DO END IF DO k=1, kde-1 grid%dnw(k) = grid%znw(k+1) - grid%znw(k) grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) END DO DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) grid%fnp(k) = .5* grid%dnw(k )/grid%dn(k) grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k) END DO cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) cof2 = grid%dn(2) /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) grid%cf1 = grid%fnp(2) + cof1 grid%cf2 = grid%fnm(2) - cof1 - cof2 grid%cf3 = cof2 grid%cfn = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1) grid%cfn1 = -.5*grid%dnw(kde-1)/grid%dn(kde-1) grid%rdx = 1./config_flags%dx grid%rdy = 1./config_flags%dy DO j=jts,jte DO i=its,ite IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%ph0(i,1,j) = grid%ht(i,j) * g grid%ph_2(i,1,j) = 0. END DO END DO DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 ) DO k = 1, kte-1 grid%php(i,k,j) = grid%c3f(k)*(p_surf - grid%p_top)+grid%c4f(k) + grid%p_top grid%pb(i,k,j) = grid%c3h(k)*(p_surf - grid%p_top)+grid%c4h(k) + grid%p_top temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) ) IF ( grid%pb(i,k,j) .LT. p_strat ) THEN temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat ) ENDIF grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm END DO grid%php(i,kte,j) = grid%p_top grid%MUB(i,j) = p_surf - grid%p_top pd_surf = grid%MU0(i,j) + grid%p_top grid%phb(i,1,j) = grid%ht(i,j) * g IF (grid%hypsometric_opt == 1) THEN DO kk = 2,kte k = kk-1 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) END DO ELSE IF (grid%hypsometric_opt == 2) THEN DO k = 2,kte pfu = grid%c3f(k )*grid%MUB(i,j)+grid%c4f(k ) + grid%p_top pfd = grid%c3f(k-1)*grid%MUB(i,j)+grid%c4f(k-1) + grid%p_top phm = grid%c3h(k-1)*grid%MUB(i,j)+grid%c4h(k-1) + grid%p_top grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu) END DO ELSE CALL wrf_error_fatal3("",3712,& 'initialize_real: hypsometric_opt should be 1 or 2' ) END IF END DO END DO IF ( ite .EQ. ide ) THEN i = ide DO j = jts, MIN(jde-1,jte) grid%MUB(i,j) = grid%MUB(i-1,j) grid%MU_2(i,j) = grid%MU_2(i-1,j) DO k = 1, kte-1 grid%pb(i,k,j) = grid%pb(i-1,k,j) grid%t_init(i,k,j) = grid%t_init(i-1,k,j) grid%alb(i,k,j) = grid%alb(i-1,k,j) END DO DO k = 1, kte grid%phb(i,k,j) = grid%phb(i-1,k,j) END DO END DO END IF IF ( jte .EQ. jde ) THEN j = jde DO i = its, ite grid%MUB(i,j) = grid%MUB(i,j-1) grid%MU_2(i,j) = grid%MU_2(i,j-1) DO k = 1, kte-1 grid%pb(i,k,j) = grid%pb(i,k,j-1) grid%t_init(i,k,j) = grid%t_init(i,k,j-1) grid%alb(i,k,j) = grid%alb(i,k,j-1) END DO DO k = 1, kte grid%phb(i,k,j) = grid%phb(i,k,j-1) END DO END DO END IF DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%MU_2(i,j) = grid%MU0(i,j) - grid%MUB(i,j) END DO END DO IF ( ite .EQ. ide ) THEN i = ide DO j = jts, MIN(jde-1,jte) grid%MU_2(i,j) = grid%MU_2(i-1,j) END DO END IF IF ( jte .EQ. jde ) THEN j = jde DO i = its, ite grid%MU_2(i,j) = grid%MU_2(i,j-1) END DO END IF lev500 = 0 DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE DO k = 1 , kde-1 grid%t_2(i,k,j) = grid%t_2(i,k,j) - t0 END DO dpmu = 10001. loop_count = 0 DO WHILE ( ( ABS(dpmu) .GT. 10. ) .AND. & ( loop_count .LT. 5 ) ) loop_count = loop_count + 1 kk = kte-1 k = kk+1 qtot=0. DO im = PARAM_FIRST_SCALAR, num_3d_m qtot = qtot + moist(i,kk,j,im) ENDDO qvf2 = 1./(1.+qtot) qvf1 = qtot*qvf2 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 qvf = 1. + rvovrd*moist(i,kk,j,P_QV) grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf& *(((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) DO kk=kte-2,1,-1 k = kk + 1 qtot=0. DO im = PARAM_FIRST_SCALAR, num_3d_m qtot = qtot + 0.5*(moist(i,kk,j,im)+moist(i,kk+1,j,im)) ENDDO qvf2 = 1./(1.+qtot) qvf1 = qtot*qvf2 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) qvf = 1. + rvovrd*moist(i,kk,j,P_QV) grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* & (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) END DO IF (grid%hypsometric_opt == 1) THEN DO kk = 2,kte k = kk - 1 grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - & 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) & + (grid%c1h(k)*grid%mu_2(i,j))*grid%alb(i,kk-1,j) ) grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j) END DO ELSE IF (grid%hypsometric_opt == 2) THEN grid%ph_2(i,1,j) = grid%phb(i,1,j) DO k = 2,kte pfu = grid%c3f(k )*grid%MU0(i,j)+grid%c4f(k ) + grid%p_top pfd = grid%c3f(k-1)*grid%MU0(i,j)+grid%c4f(k-1) + grid%p_top phm = grid%c3h(k-1)*grid%MU0(i,j)+grid%c4h(k-1) + grid%p_top grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu) END DO DO k = 1,kte grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j) END DO END IF IF (grid%hypsometric_opt == 1) THEN DO k=kts,kte-1 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)) & +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j))) ENDDO ELSE IF (grid%hypsometric_opt == 2) THEN DO k=kts,kte-1 pfu = grid%c3f(k+1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k+1)+grid%p_top pfd = grid%c3f(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k )+grid%p_top phm = grid%c3h(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k )+grid%p_top 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)) & +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j))) 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)) & /phm/LOG(pfd/pfu)-grid%alb(i,k,j) ENDDO END IF DO k=kts,kte-1 qvf = 1.+rvovrd*moist(i,k,j,P_QV) grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ & (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv & -grid%pb(i,k,j) grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) grid%alt(i,k,j) = grid%al(i,k,j) + grid%alb(i,k,j) ENDDO IF ( ( flag_metgrid .EQ. 1 ) .AND. ( i .EQ. i_valid ) .AND. ( j .EQ. j_valid ) ) THEN DO k = 1 , num_metgrid_levels IF ( ABS ( grid%p_gc(i,k,j) - 50000. ) .LT. 1. ) THEN lev500 = k EXIT END IF END DO END IF IF ( ( flag_metgrid .EQ. 1 ) .AND. & ( flag_ptheta .EQ. 0 ) .AND. & ( config_flags%adjust_heights ) .AND. & ( lev500 .NE. 0 ) ) THEN DO k = 2 , kte-1 pl = grid%php(i,k ,j) + & ( grid%p(i,k-1 ,j) * ( grid%znw(k ) - grid%znu(k ) ) + & grid%p(i,k ,j) * ( grid%znu(k-1 ) - grid%znw(k ) ) ) / & ( grid%znu(k-1 ) - grid%znu(k ) ) pu = grid%php(i,k+1,j) + & ( grid%p(i,k-1+1,j) * ( grid%znw(k +1) - grid%znu(k+1) ) + & grid%p(i,k +1,j) * ( grid%znu(k-1+1) - grid%znw(k+1) ) ) / & ( grid%znu(k-1+1) - grid%znu(k+1) ) IF ( ( pl .GE. 50000. ) .AND. ( pu .LT. 50000. ) ) THEN zl = ( grid%ph_2(i,k ,j) + grid%phb(i,k ,j) ) / g zu = ( grid%ph_2(i,k+1,j) + grid%phb(i,k+1,j) ) / g z500 = ( zl * ( LOG(50000.) - LOG(pu ) ) + & zu * ( LOG(pl ) - LOG(50000.) ) ) / & ( LOG(pl) - LOG(pu) ) dz500 = z500 - grid%ght_gc(i,lev500,j) tvsfc = ((grid%t_2(i,1,j)+t0)*((grid%p(i,1,j)+grid%php(i,1,j))/p1000mb)**(r_d/cp)) * & (1.+0.6*moist(i,1,j,P_QV)) dpmu = ( grid%php(i,1,j) + grid%p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) ) dpmu = dpmu - ( grid%php(i,1,j) + grid%p(i,1,j) ) grid%MU_2(i,j) = grid%MU_2(i,j) - dpmu EXIT END IF END DO ELSE dpmu = 0. END IF END DO END DO END DO grid%v_1 = grid%t_2+t0 CALL theta_to_t ( grid%v_1 , grid%p_hyd , p00 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IF ( .not.config_flags%use_sh_qv ) THEN IF ( config_flags%rh2qv_method .eq. 1 ) THEN CALL rh_to_mxrat1(grid%u_1, grid%v_1, grid%p_hyd , moist(:,:,:,P_QV) , & config_flags%rh2qv_wrt_liquid , & config_flags%qv_max_p_safe , & config_flags%qv_max_flag , config_flags%qv_max_value , & config_flags%qv_min_p_safe , & config_flags%qv_min_flag , config_flags%qv_min_value , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte-1 ) ELSE IF ( config_flags%rh2qv_method .eq. 2 ) THEN CALL rh_to_mxrat2(grid%u_1, grid%v_1, grid%p_hyd , moist(:,:,:,P_QV) , & config_flags%rh2qv_wrt_liquid , & config_flags%qv_max_p_safe , & config_flags%qv_max_flag , config_flags%qv_max_value , & config_flags%qv_min_p_safe , & config_flags%qv_min_flag , config_flags%qv_min_value , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte-1 ) END IF END IF IF ( config_flags%rebalance .EQ. 0 ) THEN DO j = jts, min(jde-1,jte) DO k=kts,kte-1 DO i = its, min(ide,ite) qvf = 1.+rvovrd*moist(i,k,j,P_QV) grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ & (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv & -grid%pb(i,k,j) grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) ENDDO ENDDO ENDDO ELSE lev500 = 0 DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE dpmu = 10001. loop_count = 0 DO WHILE ( ( ABS(dpmu) .GT. 10. ) .AND. & ( loop_count .LT. 5 ) ) loop_count = loop_count + 1 kk = kte-1 k=kk+1 qtot=0. DO im = PARAM_FIRST_SCALAR, num_3d_m qtot = qtot + moist(i,kk,j,im) ENDDO qvf2 = 1./(1.+qtot) qvf1 = qtot*qvf2 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 qvf = 1. + rvovrd*moist(i,kk,j,P_QV) grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf& *(((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) DO kk=kte-2,1,-1 k = kk + 1 qtot=0. DO im = PARAM_FIRST_SCALAR, num_3d_m qtot = qtot + 0.5*(moist(i,kk,j,im)+moist(i,kk+1,j,im)) ENDDO qvf2 = 1./(1.+qtot) qvf1 = qtot*qvf2 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) qvf = 1. + rvovrd*moist(i,kk,j,P_QV) grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* & (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) END DO IF (grid%hypsometric_opt == 1) THEN DO kk = 2,kte k = kk-1 grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - & 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) & + (grid%c1h(k)*grid%mu_2(i,j))*grid%alb(i,kk-1,j) ) grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j) END DO ELSE IF (grid%hypsometric_opt == 2) THEN grid%ph_2(i,1,j) = grid%phb(i,1,j) DO k = 2,kte pfu = grid%c3f(k )*grid%MU0(i,j)+grid%c4f(k ) + grid%p_top pfd = grid%c3f(k-1)*grid%MU0(i,j)+grid%c4f(k-1) + grid%p_top phm = grid%c3h(k-1)*grid%MU0(i,j)+grid%c4h(k-1) + grid%p_top grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu) END DO DO k = 1,kte grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j) END DO END IF IF (grid%hypsometric_opt == 1) THEN DO k=kts,kte-1 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)) & +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j))) ENDDO ELSE IF (grid%hypsometric_opt == 2) THEN DO k=kts,kte-1 pfu = grid%c3f(k+1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k+1)+grid%p_top pfd = grid%c3f(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k )+grid%p_top phm = grid%c3h(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k )+grid%p_top 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)) & /phm/LOG(pfd/pfu)-grid%alb(i,k,j) ENDDO END IF DO k=kts,kte-1 qvf = 1.+rvovrd*moist(i,k,j,P_QV) grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ & (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv & -grid%pb(i,k,j) grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) grid%alt(i,k,j) = grid%al(i,k,j) + grid%alb(i,k,j) ENDDO IF ( ( flag_metgrid .EQ. 1 ) .AND. ( i .EQ. i_valid ) .AND. ( j .EQ. j_valid ) ) THEN DO k = 1 , num_metgrid_levels IF ( ABS ( grid%p_gc(i,k,j) - 50000. ) .LT. 1. ) THEN lev500 = k EXIT END IF END DO END IF IF ( ( flag_metgrid .EQ. 1 ) .AND. & ( flag_ptheta .EQ. 0 ) .AND. & ( config_flags%adjust_heights ) .AND. & ( lev500 .NE. 0 ) ) THEN DO k = 2 , kte-1 pl = grid%php(i,k ,j) + & ( grid%p(i,k-1 ,j) * ( grid%znw(k ) - grid%znu(k ) ) + & grid%p(i,k ,j) * ( grid%znu(k-1 ) - grid%znw(k ) ) ) / & ( grid%znu(k-1 ) - grid%znu(k ) ) pu = grid%php(i,k+1,j) + & ( grid%p(i,k-1+1,j) * ( grid%znw(k +1) - grid%znu(k+1) ) + & grid%p(i,k +1,j) * ( grid%znu(k-1+1) - grid%znw(k+1) ) ) / & ( grid%znu(k-1+1) - grid%znu(k+1) ) IF ( ( pl .GE. 50000. ) .AND. ( pu .LT. 50000. ) ) THEN zl = ( grid%ph_2(i,k ,j) + grid%phb(i,k ,j) ) / g zu = ( grid%ph_2(i,k+1,j) + grid%phb(i,k+1,j) ) / g z500 = ( zl * ( LOG(50000.) - LOG(pu ) ) + & zu * ( LOG(pl ) - LOG(50000.) ) ) / & ( LOG(pl) - LOG(pu) ) dz500 = z500 - grid%ght_gc(i,lev500,j) tvsfc = ((grid%t_2(i,1,j)+t0)*((grid%p(i,1,j)+grid%php(i,1,j))/p1000mb)**(r_d/cp)) * & (1.+0.6*moist(i,1,j,P_QV)) dpmu = ( grid%php(i,1,j) + grid%p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) ) dpmu = dpmu - ( grid%php(i,1,j) + grid%p(i,1,j) ) grid%MU_2(i,j) = grid%MU_2(i,j) - dpmu EXIT END IF END DO ELSE dpmu = 0. END IF END DO ENDDO ENDDO END IF IF ( flag_metgrid .NE. 1 ) THEN DO j = jts, min(jde-1,jte) DO i = its, min(ide,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%u10(i,j)=grid%u_2(i,1,j) END DO END DO DO j = jts, min(jde,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%v10(i,j)=grid%v_2(i,1,j) END DO END DO DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 ) grid%psfc(i,j)=p_surf + grid%p(i,1,j) grid%q2(i,j)=moist(i,1,j,P_QV) grid%th2(i,j)=grid%t_2(i,1,j)+300. grid%t2(i,j)=grid%th2(i,j)*(((grid%p(i,1,j)+grid%pb(i,1,j))/p00)**(r_d/cp)) END DO END DO ELSE IF ( flag_metgrid .EQ. 1 ) THEN DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%th2(i,j)=grid%t2(i,j)*(p00/(grid%p(i,1,j)+grid%pb(i,1,j)))**(r_d/cp) END DO END DO IF ( flag_qv .NE. 1 ) THEN DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%q2(i,j)=grid%qv_gc(i,1,j) END DO END DO END IF END IF CALL cpu_time(t_end) grid%save_topo_from_real=1 IF (config_flags%tracer_opt .eq. 2) THEN DO j = (jde + jds)/2 - 4, (jde + jds)/2 + 4, 1 DO i = (ide + ids)/2 - 4, (ide + ids)/2 + 4, 1 IF ( its .LE. i .and. ite .GE. i .and. jts .LE. j .and. jte .GE. j ) THEN tracer(i, 1, j, P_tr17_1) = 1. tracer(i, 1, j, P_tr17_2) = 1. tracer(i, 1, j, P_tr17_3) = 1. tracer(i, 1, j, P_tr17_4) = 1. END IF END DO END DO END IF IF ( config_flags%sf_ocean_physics .EQ. PWP3DSCHEME ) THEN DO k = 1,model_config_rec%ocean_levels grid%om_depth(:,k,:) = model_config_rec%ocean_z(k) grid%om_tmp (:,k,:) = model_config_rec%ocean_t(k) grid%om_s (:,k,:) = model_config_rec%ocean_s(k) grid%om_tini (:,k,:) = model_config_rec%ocean_t(k) grid%om_sini (:,k,:) = model_config_rec%ocean_s(k) grid%om_u (:,k,:) = 0. grid%om_v (:,k,:) = 0. END DO grid%om_ml = 5 grid%om_lon = grid%xlong grid%om_lat = grid%xlat IF ( ( grid%landmask(i,j) .LT. 0.5 ) .AND. ( flag_sst .EQ. 1 ) ) THEN DO j = jts, min(jde-1,jte) DO k = 1,model_config_rec%ocean_levels DO i = its, min(ide-1,ite) grid%om_tmp(i,k,j) = grid%sst(i,j) - ( grid%om_tini(i,1,j) - grid%om_tini(i,k,j) ) END DO END DO END DO DO j = jts, min(jde-1,jte) DO k = 1,model_config_rec%ocean_levels DO i = its, min(ide-1,ite) grid%om_tini(i,k,j) = grid%om_tmp(i,k,j) END DO END DO END DO END IF END IF ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte if_thompsonaero_2d: IF ((config_flags%mp_physics .EQ. THOMPSONAERO & .OR. config_flags%mp_physics .EQ. RCON_MP_SCHEME) .AND. & config_flags%wif_input_opt .GT. 0) THEN select_aer_init_opt_2d: select case (aer_init_opt) case (0) CALL wrf_debug (0 , 'COMMENT: Surface emissions of QNWFA will be computed in microphysics') CALL wrf_debug (0 , 'COMMENT: Surface emissions of QNIFA will be initialized to zero values') do j = jts, MIN(jde-1,jte) do i = its, MIN(ide-1,ite) grid%qnwfa2d(i,j) = 0.0 grid%qnifa2d(i,j) = 0.0 enddo enddo case (1) CALL wrf_debug (0 , 'Calculating anthropogenic surface emissions of QNWFA using climatology') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g grid%qnwfa2d(i,j) = grid%w_wif_now(i,1,j) * 0.000196 * (50./z1) enddo enddo CALL wrf_debug (0 , 'Setting surface emissions of QNIFA to zero') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) grid%qnifa2d(i,j) = 0.0 enddo enddo if (config_flags%wif_input_opt .EQ. 2) then CALL wrf_debug (0 , 'Calculating anthropogenic surface emissions of QNBCA using climatology') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g grid%qnbca2d(i,j) = grid%b_wif_now(i,1,j) * 0.000098 * (50./z1) * (1. + grid%frc_urb2d(i,j)) enddo enddo end if case (2) if (flag_qnwfa2d .EQ. 1) then CALL wrf_debug (0 , 'Calculating anthropogenic surface emissions of QNWFA using first guess') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g grid%qnwfa2d(i,j) = grid%qnwfa2d(i,j) * grid%alt(i,1,j) / z1 enddo enddo else CALL wrf_debug (0 , 'Using first guess aerosol option, but no anthropogenic surface emissions of QNWFA found') CALL wrf_debug (0 , 'Setting anthropogenic surface emissions of QNWFA to zero') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) grid%qnwfa2d(i,j) = 0.0 enddo enddo end if if (flag_qnifa2d .EQ. 1) then CALL wrf_debug (0 , 'Calculating surface emissions of QNIFA using first guess') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g grid%qnifa2d(i,j) = grid%qnifa2d(i,j) * grid%alt(i,1,j) / z1 enddo enddo else CALL wrf_debug (0 , 'Using first guess aerosol option, but no surface emissions of QNIFA found') CALL wrf_debug (0 , 'Setting surface emissions of QNIFA to zero') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) grid%qnifa2d(i,j) = 0.0 enddo enddo end if if (config_flags%wif_input_opt .EQ. 2) then if (flag_qnbca2d .EQ. 1) then CALL wrf_debug (0 , 'Calculating surface emissions of QNBCA using first guess') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g grid%qnbca2d(i,j) = grid%qnbca2d(i,j) * grid%alt(i,1,j) / z1 enddo enddo else CALL wrf_debug (0 , 'Using first guess aerosol option, but no surface emissions of QNBCA found') CALL wrf_debug (0 , 'Setting surface emissions of QNBCA to zero') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) grid%qnbca2d(i,j) = 0.0 enddo enddo end if end if if (config_flags%aer_fire_emit_opt .GT. 0) then if (flag_qnocbb2d .EQ. 1) then CALL wrf_debug (0 , 'Calculating biomass burning surface emissions of organic carbon aerosol using first guess') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g grid%qnocbb2d(i,j) = grid%qnocbb2d(i,j) * grid%alt(i,1,j) / z1 enddo enddo else CALL wrf_debug (0 , 'Using first guess aerosol option, but no biomass burning surface emissions of organic carbon aerosol found') CALL wrf_debug (0 , 'Setting biomass burning surface emissions of organic carbon aerosol to zero') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) grid%qnocbb2d(i,j) = 0.0 enddo enddo end if if (config_flags%aer_fire_emit_opt .EQ. 2) then if (flag_qnbcbb2d .EQ. 1) then CALL wrf_debug (0 , 'Calculating biomass burning surface emissions of black carbon aerosol using first guess') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) z1 = (grid%phb(i,2,j)-grid%phb(i,1,j))/g grid%qnbcbb2d(i,j) = grid%qnbcbb2d(i,j) * grid%alt(i,1,j) / z1 enddo enddo else CALL wrf_debug (0 , 'Using first guess aerosol option, but no biomass burning surface emissions of black carbon aerosol found') CALL wrf_debug (0 , 'Setting biomass burning surface emissions of black carbon aerosol to zero') do j = jts, min(jde-1,jte) do i = its, min(ide-1,ite) grid%qnbcbb2d(i,j) = 0.0 enddo enddo end if end if else CALL wrf_debug (0 , 'Skipping biomass burning surface emissions') end if case default CALL wrf_debug (0 , 'aer_init_opt = ', aer_init_opt) CALL wrf_error_fatal3("",4527,& 'Aerosol forcing option does not exist for mp_physics=28' ) end select select_aer_init_opt_2d ENDIF if_thompsonaero_2d if (config_flags%insert_init_cloud .AND. & (P_QC .gt. PARAM_FIRST_SCALAR .AND. & P_QI .gt. PARAM_FIRST_SCALAR)) then ALLOCATE(temp_P(kts:kte-1)) ALLOCATE(temp_Dz(kts:kte-1)) ALLOCATE(temp_T(kts:kte-1)) ALLOCATE(temp_R(kts:kte-1)) ALLOCATE(temp_Qv(kts:kte-1)) ALLOCATE(temp_Qc(kts:kte-1)) ALLOCATE(temp_Nc(kts:kte-1)) ALLOCATE(temp_Qi(kts:kte-1)) ALLOCATE(temp_Ni(kts:kte-1)) ALLOCATE(temp_Qs(kts:kte-1)) ALLOCATE(temp_CF(kts:kte-1)) i_end = MIN(ite,ide-1) j_end = MIN(jte,jde-1) max_relh = 1.5 max_relh = wrf_dm_max_real ( MAXVAL(grid%u_1(its:i_end,:,jts:j_end)) ) max_relh = max_relh*0.01 gridkm = SQRT(config_flags%dx*config_flags%dy)*0.001 IF ( internal_time_loop .GT. 1 ) THEN grid%v_1 = grid%t_2+t0 CALL theta_to_t ( grid%v_1 , grid%p_hyd , p00 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) ENDIF do j = jts, j_end do i = its, i_end IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE debug_flag = .false. temp_xland = grid%xland(i,j) if (grid%lakemask(i,j) .eq. 1) temp_xland = 1 do k = kts, kte-1 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 temp_P(k) = grid%p_hyd(i,k,j) temp_T(k) = grid%v_1(i,k,j) temp_R(k) = 1./grid%alt(i,k,j) temp_Qv(k) = moist(i,k,j,P_QV) temp_Qc(k) = MAX(0., moist(i,k,j,P_QC)) temp_Qi(k) = MAX(0., moist(i,k,j,P_QI)) if (P_QS .gt. 1) then temp_Qs(k) = MAX(0., moist(i,k,j,P_QS)) else temp_Qs(k) = 0. endif if (P_QNI .gt. 1) then temp_Ni(k) = MAX(0., scalar(i,k,j,P_QNI)) else temp_Ni(k) = 0. endif if (P_QNC .gt. 1) then temp_Nc(k) = MAX(0., scalar(i,k,j,P_QNC)) else temp_Nc(k) = 0. endif temp_CF(k) = 0. enddo call cal_cldfra3(temp_CF,temp_Qv,temp_Qc,temp_Qi,temp_Qs, & & temp_Dz, temp_P, temp_T, temp_xland, gridkm, & & config_flags%insert_init_cloud, max_relh, & & kts, kte-1, debug_flag) do k = kts, kte-1 grid%cldfra(i,k,j) = temp_CF(k) enddo if (debug_flag) then do k = kts, kte-1 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) enddo endif do k = kts, kte-1 moist(i,k,j,P_QV) = MAX(temp_Qv(k), moist(i,k,j,P_QV)) moist(i,k,j,P_QC) = temp_Qc(k) moist(i,k,j,P_QI) = temp_Qi(k) enddo enddo enddo DEALLOCATE(temp_P) DEALLOCATE(temp_Dz) DEALLOCATE(temp_T) DEALLOCATE(temp_R) DEALLOCATE(temp_Qv) DEALLOCATE(temp_Qc) DEALLOCATE(temp_Nc) DEALLOCATE(temp_Qi) DEALLOCATE(temp_Ni) DEALLOCATE(temp_Qs) DEALLOCATE(temp_CF) endif IF ( config_flags%mp_physics .EQ. THOMPSON .OR. & config_flags%mp_physics .EQ. THOMPSONAERO .OR. & config_flags%mp_physics .EQ. RCON_MP_SCHEME & ) THEN IF ( internal_time_loop .GT. 1 ) THEN grid%v_1 = grid%t_2+t0 CALL theta_to_t ( grid%v_1 , grid%p_hyd , p00 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) ENDIF do j = jts, MIN(jte,jde-1) do i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE do k = kts, kte-1 temp_rho = 1./grid%alt(i,k,j) 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 if (P_QNWFA .gt. 1) then scalar(i,k,j,P_QNC) = make_DropletNumber (moist(i,k,j,P_QC)*temp_rho, & & scalar(i,k,j,P_QNWFA)*temp_rho, grid%xland(i,j)) else scalar(i,k,j,P_QNC) = make_DropletNumber (moist(i,k,j,P_QC)*temp_rho, & & 0.0, grid%xland(i,j)) endif scalar(i,k,j,P_QNC) = scalar(i,k,j,P_QNC) / temp_rho endif 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 scalar(i,k,j,P_QNI) = make_IceNumber (moist(i,k,j,P_QI)*temp_rho, grid%v_1(i,k,j)) scalar(i,k,j,P_QNI) = scalar(i,k,j,P_QNI) / temp_rho endif 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 scalar(i,k,j,P_QNR) = make_RainNumber (moist(i,k,j,P_QR)*temp_rho, grid%v_1(i,k,j)) scalar(i,k,j,P_QNR) = scalar(i,k,j,P_QNR) / temp_rho endif enddo enddo enddo ENDIF if (config_flags%madwrf_cldinit == 1) & 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, & grid%alt, grid%xland, grid%cldmask, grid%cldtopz, grid%cldbasez, grid%brtemp, grid%ht, grid%dx, grid%dy, & flag_cldmask, flag_cldtopz, flag_cldbasez, flag_brtemp, em_width, hold_ups, ids, ide, jds, jde, its, ims, & ime, jms, jme, kms, kme, ite, jts, jte, kts, kte, grid%cldfra) if (config_flags%madwrf_opt == 2) then if (f_qc .and. f_qi .and. f_qs) then call Init_madwrf_tracers (tracer, moist, p_qc, p_qi, p_qs, p_tr_qc, p_tr_qi, p_tr_qs, & ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, its, ite, jts, jte, kts, kte) else call wrf_error_fatal3("",4729,& 'madwrf_opt=2 requires a mp_physics option with qc, qi and qs') end if end if grid%got_var_sso = .FALSE. DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF(grid%var_sso(i,j) .NE. 0) THEN grid%got_var_sso = .true. ENDIF END DO END DO grid%got_var_sso = wrf_dm_lor_logical ( grid%got_var_sso ) DO j = jts, min(jde-1,jte) DO k = kts, kte DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%th_phy_m_t0(i,k,j) = grid%t_2(i,k,j) END DO END DO END DO IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN DO j = jts, min(jde-1,jte) DO k = kts, kte DO i = its, min(ide,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE 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 END DO END DO END DO END IF CALL HALO_EM_INIT_1_sub ( grid, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL HALO_EM_INIT_2_sub ( grid, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL HALO_EM_INIT_3_sub ( grid, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL HALO_EM_INIT_4_sub ( grid, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL HALO_EM_INIT_5_sub ( grid, & num_moist, & moist, & num_chem, & chem, & num_scalar, & scalar, & num_tracer, & tracer, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) IF ( config_flags%sf_ocean_physics .EQ. PWP3DSCHEME ) THEN CALL HALO_EM_INIT_6_sub ( grid, & config_flags, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) END IF RETURN END SUBROUTINE init_domain_rk SUBROUTINE const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat ) USE module_configure IMPLICIT NONE REAL , INTENT(OUT) :: p00 , t00 , a , tiso , p_strat , a_strat CALL nl_get_base_pres ( 1 , p00 ) CALL nl_get_base_temp ( 1 , t00 ) CALL nl_get_base_lapse ( 1 , a ) CALL nl_get_iso_temp ( 1 , tiso ) CALL nl_get_base_pres_strat ( 1 , p_strat ) CALL nl_get_base_lapse_strat ( 1 , a_strat ) END SUBROUTINE const_module_initialize SUBROUTINE rebalance_driver ( grid ) IMPLICIT NONE TYPE (domain) :: grid CALL rebalance( grid & ,grid%moist,grid%moist_bxs,grid%moist_bxe,grid%moist_bys,grid%moist_bye,grid%moist_btxs,grid%moist_btxe,grid%moist_btys, & grid%moist_btye,grid%dfi_moist,grid%dfi_moist_bxs,grid%dfi_moist_bxe,grid%dfi_moist_bys,grid%dfi_moist_bye,grid%dfi_moist_btxs, & grid%dfi_moist_btxe,grid%dfi_moist_btys,grid%dfi_moist_btye,grid%scalar,grid%scalar_bxs,grid%scalar_bxe,grid%scalar_bys, & grid%scalar_bye,grid%scalar_btxs,grid%scalar_btxe,grid%scalar_btys,grid%scalar_btye,grid%dfi_scalar,grid%dfi_scalar_bxs, & grid%dfi_scalar_bxe,grid%dfi_scalar_bys,grid%dfi_scalar_bye,grid%dfi_scalar_btxs,grid%dfi_scalar_btxe,grid%dfi_scalar_btys, & grid%dfi_scalar_btye,grid%aerod,grid%aerocu,grid%ozmixm,grid%aerosolc_1,grid%aerosolc_2,grid%fdda3d,grid%fdda2d,grid%advh_t, & grid%advz_t,grid%tracer,grid%tracer_bxs,grid%tracer_bxe,grid%tracer_bys,grid%tracer_bye,grid%tracer_btxs,grid%tracer_btxe, & grid%tracer_btys,grid%tracer_btye,grid%pert3d,grid%nba_mij,grid%nba_rij,grid%sbmradar,grid%chem & ) END SUBROUTINE rebalance_driver SUBROUTINE rebalance ( grid & ,moist,moist_bxs,moist_bxe,moist_bys,moist_bye,moist_btxs,moist_btxe,moist_btys,moist_btye,dfi_moist,dfi_moist_bxs,dfi_moist_bxe, & dfi_moist_bys,dfi_moist_bye,dfi_moist_btxs,dfi_moist_btxe,dfi_moist_btys,dfi_moist_btye,scalar,scalar_bxs,scalar_bxe,scalar_bys, & scalar_bye,scalar_btxs,scalar_btxe,scalar_btys,scalar_btye,dfi_scalar,dfi_scalar_bxs,dfi_scalar_bxe,dfi_scalar_bys, & dfi_scalar_bye,dfi_scalar_btxs,dfi_scalar_btxe,dfi_scalar_btys,dfi_scalar_btye,aerod,aerocu,ozmixm,aerosolc_1,aerosolc_2,fdda3d, & fdda2d,advh_t,advz_t,tracer,tracer_bxs,tracer_bxe,tracer_bys,tracer_bye,tracer_btxs,tracer_btxe,tracer_btys,tracer_btye,pert3d, & nba_mij,nba_rij,sbmradar,chem & ) IMPLICIT NONE TYPE (domain) :: grid real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_moist) :: moist real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_bxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_bxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_bys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_bye real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_btxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_btxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_btys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_moist) :: moist_btye real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_dfi_moist) :: dfi_moist real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_bxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_bxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_bys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_bye real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_btxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_btxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_btys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_moist) :: dfi_moist_btye real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_scalar) :: scalar real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_bxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_bxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_bys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_bye real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_btxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_btxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_btys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_scalar) :: scalar_btye real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_dfi_scalar) :: dfi_scalar real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_bxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_bxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_bys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_bye real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_btxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_btxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_btys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_dfi_scalar) :: dfi_scalar_btye real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_aerod) :: aerod real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_aerocu) :: aerocu real ,DIMENSION(grid%sm31:grid%em31,1:grid%levsiz,grid%sm33:grid%em33,num_ozmixm) :: ozmixm real ,DIMENSION(grid%sm31:grid%em31,1:grid%paerlev,grid%sm33:grid%em33,num_aerosolc) :: aerosolc_1 real ,DIMENSION(grid%sm31:grid%em31,1:grid%paerlev,grid%sm33:grid%em33,num_aerosolc) :: aerosolc_2 real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_fdda3d) :: fdda3d real ,DIMENSION(grid%sm31:grid%em31,1:1,grid%sm33:grid%em33,num_fdda2d) :: fdda2d real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_advh_t) :: advh_t real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_advz_t) :: advz_t real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_tracer) :: tracer real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_bxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_bxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_bys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_bye real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_btxs real ,DIMENSION(grid%sm33:grid%em33,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_btxe real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_btys real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%spec_bdy_width,num_tracer) :: tracer_btye real ,DIMENSION(grid%sm31:grid%em31,1:grid%num_stoch_levels,grid%sm33:grid%em33,num_pert3d) :: pert3d real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_nba_mij) :: nba_mij real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_nba_rij) :: nba_rij real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_sbmradar) :: sbmradar real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_chem) :: chem TYPE (grid_config_rec_type) :: config_flags REAL :: p_surf , pd_surf, p_surf_int , pb_int , ht_hold REAL :: qvf , qvf1 , qvf2 REAL :: p00 , t00 , a , tiso , p_strat , a_strat REAL , DIMENSION(:,:,:) , ALLOCATABLE :: t_init_int INTEGER :: num_veg_cat , num_soil_top_cat , num_soil_bot_cat INTEGER :: & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte, & ips, ipe, jps, jpe, kps, kpe, & i, j, k, kk REAL :: temp, temp_int REAL :: pfu, pfd, phm REAL :: w1, w2, z0, z1, z2 SELECT CASE ( model_data_order ) CASE ( DATA_ORDER_ZXY ) kds = grid%sd31 ; kde = grid%ed31 ; ids = grid%sd32 ; ide = grid%ed32 ; jds = grid%sd33 ; jde = grid%ed33 ; kms = grid%sm31 ; kme = grid%em31 ; ims = grid%sm32 ; ime = grid%em32 ; jms = grid%sm33 ; jme = grid%em33 ; kts = grid%sp31 ; kte = grid%ep31 ; its = grid%sp32 ; ite = grid%ep32 ; jts = grid%sp33 ; jte = grid%ep33 ; CASE ( DATA_ORDER_XYZ ) ids = grid%sd31 ; ide = grid%ed31 ; jds = grid%sd32 ; jde = grid%ed32 ; kds = grid%sd33 ; kde = grid%ed33 ; ims = grid%sm31 ; ime = grid%em31 ; jms = grid%sm32 ; jme = grid%em32 ; kms = grid%sm33 ; kme = grid%em33 ; its = grid%sp31 ; ite = grid%ep31 ; jts = grid%sp32 ; jte = grid%ep32 ; kts = grid%sp33 ; kte = grid%ep33 ; CASE ( DATA_ORDER_XZY ) ids = grid%sd31 ; ide = grid%ed31 ; kds = grid%sd32 ; kde = grid%ed32 ; jds = grid%sd33 ; jde = grid%ed33 ; ims = grid%sm31 ; ime = grid%em31 ; kms = grid%sm32 ; kme = grid%em32 ; jms = grid%sm33 ; jme = grid%em33 ; its = grid%sp31 ; ite = grid%ep31 ; kts = grid%sp32 ; kte = grid%ep32 ; jts = grid%sp33 ; jte = grid%ep33 ; END SELECT ALLOCATE ( t_init_int(ims:ime,kms:kme,jms:jme) ) CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) DO j=jts,jte DO i=its,ite grid%ph0(i,1,j) = grid%ht_fine(i,j) * g grid%ph_2(i,1,j) = 0. END DO END DO IF ( config_flags%use_baseparam_fr_nml ) then CALL wrf_message('ndown: using namelist constants') CALL const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat ) ELSE CALL wrf_debug(99,'ndown: using base-state profile constants from input file') t00 = grid%t00 p00 = grid%p00 a = grid%tlp tiso = grid%tiso p_strat = grid%p_strat a_strat = grid%tlp_strat IF (t00 .LT. 100. .or. p00 .LT. 10000.) THEN WRITE(wrf_err_message,*)& 'ndown_em: did not find base state parameters in wrfout. Add use_baseparam_fr_nml = .t. in &dynamics and rerun' CALL wrf_error_fatal3("",5121,& TRIM(wrf_err_message)) ENDIF ENDIF hold_ups = .true. DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht_fine(i,j)/a/r_d ) **0.5 ) p_surf_int = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j) /a/r_d ) **0.5 ) DO k = 1, kte-1 grid%pb(i,k,j) = grid%c3h(k)*(p_surf - grid%p_top) + grid%c4h(k) + grid%p_top pb_int = grid%c3h(k)*(p_surf_int - grid%p_top) + grid%c4h(k) + grid%p_top temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) ) IF ( grid%pb(i,k,j) .LT. p_strat ) THEN temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat ) ENDIF grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 temp_int = MAX ( tiso, t00 + A*LOG(pb_int /p00) ) IF ( pb_int .LT. p_strat ) THEN temp_int = tiso + A_strat * LOG ( pb_int/p_strat ) ENDIF t_init_int(i,k,j)= temp_int*(p00/pb_int )**(r_d/cp) - t0 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm END DO grid%MUB(i,j) = p_surf - grid%p_top pd_surf = ( grid%MUB(i,j) + grid%MU_2(i,j) ) + grid%p_top grid%phb(i,1,j) = grid%ht_fine(i,j) * g IF (grid%hypsometric_opt == 1) THEN DO kk = 2,kte k = kk - 1 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) END DO ELSE IF (grid%hypsometric_opt == 2) THEN DO k = 2,kte pfu = grid%c3f(k )*grid%MUB(i,j)+grid%c4f(k ) + grid%p_top pfd = grid%c3f(k-1)*grid%MUB(i,j)+grid%c4f(k-1) + grid%p_top phm = grid%c3h(k-1)*grid%MUB(i,j)+grid%c4h(k-1) + grid%p_top grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu) END DO ELSE CALL wrf_error_fatal3("",5183,& 'initialize_real: hypsometric_opt should be 1 or 2' ) END IF END DO END DO DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%ht(i,j) = grid%ht_fine(i,j) END DO END DO DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) DO k = 1 , kde-1 grid%t_2(i,k,j) = grid%t_2(i,k,j) + ( grid%t_init(i,k,j) - t_init_int(i,k,j) ) END DO kk = kte-1 k = kk+1 qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk,j,P_QV)) qvf2 = 1./(1.+qvf1) qvf1 = qvf1*qvf2 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 qvf = 1. + rvovrd*moist(i,kk,j,P_QV) IF ( config_flags%use_theta_m .EQ. 1 ) THEN grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)* & (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) ELSE grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* & (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) END IF grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) DO kk=kte-2,1,-1 k = kk+1 qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk+1,j,P_QV)) qvf2 = 1./(1.+qvf1) qvf1 = qvf1*qvf2 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) qvf = 1. + rvovrd*moist(i,kk,j,P_QV) IF ( config_flags%use_theta_m .EQ. 1 ) THEN grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)* & (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) ELSE grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* & (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) END IF grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) END DO IF (grid%hypsometric_opt == 1) THEN DO kk = 2,kte k = kk-1 grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - & 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) & + (grid%c1h(k)*grid%mu_2(i,j))*grid%alb(i,kk-1,j) ) grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j) END DO ELSE IF (grid%hypsometric_opt == 2) THEN grid%ph_2(i,1,j) = grid%phb(i,1,j) DO k = 2,kte pfu = grid%c3f(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k )+grid%p_top pfd = grid%c3f(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k-1)+grid%p_top phm = grid%c3h(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k-1)+grid%p_top grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu) END DO DO k = 1,kte grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j) END DO DO k = 1,kte grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j) END DO END IF z0 = grid%ph0(i,1,j)/g z1 = 0.5*(grid%ph0(i,1,j)+grid%ph0(i,2,j))/g z2 = 0.5*(grid%ph0(i,2,j)+grid%ph0(i,3,j))/g w1 = (z0 - z2)/(z1 - z2) w2 = 1. - w1 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)) END DO END DO DEALLOCATE ( t_init_int ) ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte CALL HALO_EM_INIT_1_sub ( grid, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL HALO_EM_INIT_2_sub ( grid, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL HALO_EM_INIT_3_sub ( grid, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL HALO_EM_INIT_4_sub ( grid, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) CALL HALO_EM_INIT_5_sub ( grid, & num_moist, & moist, & num_chem, & chem, & num_scalar, & scalar, & num_tracer, & tracer, & local_communicator, & mytask, ntasks, ntasks_x, ntasks_y, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) END SUBROUTINE rebalance RECURSIVE SUBROUTINE find_my_parent ( grid_ptr_in , grid_ptr_out , id_i_am , id_wanted , found_the_id ) USE module_domain TYPE(domain) , POINTER :: grid_ptr_in , grid_ptr_out TYPE(domain) , POINTER :: grid_ptr_sibling INTEGER :: id_wanted , id_i_am INTEGER :: nest LOGICAL :: found_the_id found_the_id = .FALSE. grid_ptr_sibling => grid_ptr_in nest = 0 DO WHILE ( ASSOCIATED ( grid_ptr_sibling ) ) IF ( grid_ptr_sibling%grid_id .EQ. id_wanted ) THEN found_the_id = .TRUE. grid_ptr_out => grid_ptr_sibling RETURN ELSE IF ( grid_ptr_sibling%num_nests .GT. 0 .AND. nest .LT. grid_ptr_sibling%num_nests ) THEN nest = nest + 1 grid_ptr_sibling => grid_ptr_sibling%nests(nest)%ptr CALL find_my_parent ( grid_ptr_sibling , grid_ptr_out , id_i_am , id_wanted , found_the_id ) IF (.NOT. found_the_id) grid_ptr_sibling => grid_ptr_sibling%parents(1)%ptr ELSE grid_ptr_sibling => grid_ptr_sibling%sibling END IF END DO END SUBROUTINE find_my_parent RECURSIVE SUBROUTINE find_my_parent2 ( grid_ptr_in , grid_ptr_out , id_wanted , found_the_id ) USE module_domain TYPE(domain) , POINTER :: grid_ptr_in TYPE(domain) , POINTER :: grid_ptr_out INTEGER , INTENT(IN ) :: id_wanted LOGICAL , INTENT(OUT) :: found_the_id TYPE(domain) , POINTER :: grid_ptr_holder INTEGER :: kid found_the_id = .FALSE. grid_ptr_holder => grid_ptr_in IF ( id_wanted .EQ. grid_ptr_in%grid_id ) THEN found_the_id = .TRUE. grid_ptr_out => grid_ptr_in ELSE loop_over_all_kids : DO kid = 1 , grid_ptr_in%num_nests IF ( ASSOCIATED ( grid_ptr_in%nests(kid)%ptr ) ) THEN CALL find_my_parent2 ( grid_ptr_in%nests(kid)%ptr , grid_ptr_out , id_wanted , found_the_id ) IF ( found_the_id ) THEN EXIT loop_over_all_kids END IF END IF END DO loop_over_all_kids END IF END SUBROUTINE find_my_parent2 SUBROUTINE vert_interp ( fo , po , fnew , pnu , & fo_maxw , fo_trop , po_maxw , po_trop , & po_maxwnn , po_tropnn , & flag_maxw , flag_trop , & maxw_horiz_pres_diff , trop_horiz_pres_diff , & maxw_above_this_level , & generic , var_type , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: interp_type , lagrange_order , extrap_type LOGICAL , INTENT(IN) :: lowest_lev_from_sfc , use_levels_below_ground , use_surface REAL , INTENT(IN) :: zap_close_levels REAL , INTENT(IN) :: maxw_horiz_pres_diff , trop_horiz_pres_diff , maxw_above_this_level INTEGER , INTENT(IN) :: force_sfc_in_vinterp , id INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte INTEGER , INTENT(IN) :: generic INTEGER , INTENT(IN) :: flag_maxw , flag_trop CHARACTER (LEN=1) :: var_type REAL , DIMENSION(ims:ime,generic,jms:jme) , INTENT(IN) :: fo , po REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: fo_maxw , fo_trop , po_maxw , po_trop REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: po_maxwnn , po_tropnn REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: pnu REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: fnew REAL , DIMENSION(ims:ime,generic,jms:jme) :: forig , porig REAL , DIMENSION(ims:ime,jms:jme) :: forig_maxw , forig_trop , porig_maxw , porig_trop REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: pnew CHARACTER (LEN=256) :: message INTEGER :: i , j , k , ko , kn , k1 , k2 , ko_1 , ko_2 , knext INTEGER :: istart , iend , jstart , jend , kstart , kend INTEGER , DIMENSION(ims:ime,kms:kme ) :: k_above , k_below INTEGER , DIMENSION(ims:ime ) :: ks INTEGER , DIMENSION(ims:ime ) :: ko_above_sfc INTEGER :: count , zap , zap_below , zap_above , kst , kcount INTEGER :: kinterp_start , kinterp_end , sfc_level LOGICAL :: any_below_ground REAL :: p1 , p2 , pn, hold , zap_close_extra_levels REAL , DIMENSION(1:generic+flag_maxw+flag_trop) :: ordered_porig , ordered_forig REAL , DIMENSION(kts:kte) :: ordered_pnew , ordered_fnew LOGICAL :: any_valid_points INTEGER :: i_valid , j_valid LOGICAL :: flip_data_required INTEGER :: final_zap_check_count , count_close_by_at_ko LOGICAL :: ok_data INTEGER :: ii, jj zap_close_extra_levels = 500 IF ( var_type .EQ. 'U' ) THEN istart = its iend = ite jstart = MAX(jds ,jts-1) jend = MIN(jde-1,jte+1) kstart = kts kend = kte-1 DO j = jstart,jend DO k = 1,generic DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig(i,k,j) = ( po(i,k,j) + po(i-1,k,j) ) * 0.5 END DO END DO DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig_maxw(i,j) = ( po_maxw(i,j) + po_maxw(i-1,j) ) * 0.5 porig_trop(i,j) = ( po_trop(i,j) + po_trop(i-1,j) ) * 0.5 END DO IF ( ids .EQ. its ) THEN DO k = 1,generic porig(its,k,j) = po(its,k,j) END DO porig_maxw(its,j) = po_maxw(its,j) porig_trop(its,j) = po_trop(its,j) END IF IF ( ide .EQ. ite ) THEN DO k = 1,generic porig(ite,k,j) = po(ite-1,k,j) END DO porig_maxw(ite,j) = po_maxw(ite-1,j) porig_trop(ite,j) = po_trop(ite-1,j) END IF DO k = kstart,kend DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pnew(i,k,j) = ( pnu(i,k,j) + pnu(i-1,k,j) ) * 0.5 END DO END DO IF ( ids .EQ. its ) THEN DO k = kstart,kend pnew(its,k,j) = pnu(its,k,j) END DO END IF IF ( ide .EQ. ite ) THEN DO k = kstart,kend pnew(ite,k,j) = pnu(ite-1,k,j) END DO END IF END DO ELSE IF ( var_type .EQ. 'V' ) THEN istart = MAX(ids ,its-1) iend = MIN(ide-1,ite+1) jstart = jts jend = jte kstart = kts kend = kte-1 DO i = istart,iend DO k = 1,generic DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig(i,k,j) = ( po(i,k,j) + po(i,k,j-1) ) * 0.5 END DO END DO DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig_maxw(i,j) = ( po_maxw(i,j) + po_maxw(i,j-1) ) * 0.5 porig_trop(i,j) = ( po_trop(i,j) + po_trop(i,j-1) ) * 0.5 END DO IF ( jds .EQ. jts ) THEN DO k = 1,generic porig(i,k,jts) = po(i,k,jts) END DO porig_maxw(i,jts) = po_maxw(i,jts) porig_trop(i,jts) = po_trop(i,jts) END IF IF ( jde .EQ. jte ) THEN DO k = 1,generic porig(i,k,jte) = po(i,k,jte-1) END DO porig_maxw(i,jte) = po_maxw(i,jte-1) porig_trop(i,jte) = po_trop(i,jte-1) END IF DO k = kstart,kend DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pnew(i,k,j) = ( pnu(i,k,j) + pnu(i,k,j-1) ) * 0.5 END DO END DO IF ( jds .EQ. jts ) THEN DO k = kstart,kend pnew(i,k,jts) = pnu(i,k,jts) END DO END IF IF ( jde .EQ. jte ) THEN DO k = kstart,kend pnew(i,k,jte) = pnu(i,k,jte-1) END DO END IF END DO ELSE IF ( ( var_type .EQ. 'W' ) .OR. ( var_type .EQ. 'Z' ) ) THEN istart = its iend = MIN(ide-1,ite) jstart = jts jend = MIN(jde-1,jte) kstart = kts kend = kte DO j = jstart,jend DO k = 1,generic DO i = istart,iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig(i,k,j) = po(i,k,j) END DO END DO DO i = istart,iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig_maxw(i,j) = po_maxw(i,j) porig_trop(i,j) = po_trop(i,j) END DO DO k = kstart,kend DO i = istart,iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pnew(i,k,j) = pnu(i,k,j) END DO END DO END DO ELSE IF ( ( var_type .EQ. 'T' ) .OR. ( var_type .EQ. 'Q' ) ) THEN istart = its iend = MIN(ide-1,ite) jstart = jts jend = MIN(jde-1,jte) kstart = kts kend = kte-1 DO j = jstart,jend DO k = 1,generic DO i = istart,iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig(i,k,j) = po(i,k,j) END DO END DO DO i = istart,iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig_maxw(i,j) = po_maxw(i,j) porig_trop(i,j) = po_trop(i,j) END DO DO k = kstart,kend DO i = istart,iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pnew(i,k,j) = pnu(i,k,j) END DO END DO END DO ELSE istart = its iend = MIN(ide-1,ite) jstart = jts jend = MIN(jde-1,jte) kstart = kts kend = kte-1 DO j = jstart,jend DO k = 1,generic DO i = istart,iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig(i,k,j) = po(i,k,j) END DO END DO DO k = kstart,kend DO i = istart,iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pnew(i,k,j) = pnu(i,k,j) END DO END DO END DO END IF any_valid_points = .false. find_valid : DO j = jstart , jend DO i = istart , iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE any_valid_points = .true. i_valid = i j_valid = j EXIT find_valid END DO END DO find_valid IF ( .NOT. any_valid_points ) THEN RETURN END IF IF ( porig(i_valid,2,j_valid) .LT. porig(i_valid,generic,j_valid) ) THEN flip_data_required = .true. ELSE flip_data_required = .false. END IF DO j = jstart , jend IF ( flip_data_required ) THEN DO kn = 2 , ( generic + 1 ) / 2 DO i = istart , iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE hold = porig(i,kn,j) porig(i,kn,j) = porig(i,generic+2-kn,j) porig(i,generic+2-kn,j) = hold forig(i,kn,j) = fo (i,generic+2-kn,j) forig(i,generic+2-kn,j) = fo (i,kn,j) END DO END DO DO i = istart , iend forig(i,1,j) = fo (i,1,j) END DO IF ( MOD(generic,2) .EQ. 0 ) THEN k=generic/2 + 1 DO i = istart , iend forig(i,k,j) = fo (i,k,j) END DO END IF ELSE DO kn = 1 , generic DO i = istart , iend forig(i,kn,j) = fo (i,kn,j) END DO END DO END IF DO i = istart , iend ko_above_sfc(i) = -1 END DO DO ko = kstart+1 , generic DO i = istart , iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ko_above_sfc(i) .EQ. -1 ) THEN IF ( porig(i,1,j) .GT. porig(i,ko,j) ) THEN ko_above_sfc(i) = ko END IF END IF END DO END DO DO i = istart , iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE zap = 0 zap_below = 0 zap_above = 0 IF ( ko_above_sfc(i) .GT. 2 ) THEN count = 1 DO ko = 2 , ko_above_sfc(i)-1 ordered_porig(count) = porig(i,ko,j) ordered_forig(count) = forig(i,ko,j) count = count + 1 END DO IF ( ordered_porig(count-1) - porig(i,1,j) .LT. zap_close_levels ) THEN count = count -1 zap = 1 zap_below = 1 END IF ordered_porig(count) = porig(i,1,j) ordered_forig(count) = forig(i,1,j) count = count + 1 IF ( force_sfc_in_vinterp .GT. 0 ) THEN knext = ko_above_sfc(i) find_level : DO ko = ko_above_sfc(i) , generic IF ( porig(i,ko,j) .LE. pnew(i,force_sfc_in_vinterp,j) ) THEN knext = ko exit find_level ELSE zap = zap + 1 zap_above = zap_above + 1 END IF END DO find_level ELSE knext = ko_above_sfc(i) END IF IF ( ordered_porig(count-1) - porig(i,knext,j) .LT. zap_close_levels ) THEN kst = knext+1 zap = zap + 1 zap_above = zap_above + 1 ELSE kst = knext END IF DO ko = kst , generic ordered_porig(count) = porig(i,ko,j) ordered_forig(count) = forig(i,ko,j) count = count + 1 END DO ELSE zap = 0 ordered_porig(1) = porig(i,1,j) ordered_forig(1) = forig(i,1,j) count = 2 IF ( force_sfc_in_vinterp .GT. 0 ) THEN knext = 2 find_level2: DO ko = 2 , generic IF ( porig(i,ko,j) .LE. pnew(i,force_sfc_in_vinterp,j) ) THEN knext = ko exit find_level2 ELSE zap = zap + 1 zap_above = zap_above + 1 END IF END DO find_level2 ELSE knext = 2 END IF DO ko = knext , generic IF ( ( ordered_porig(count-1) - porig(i,ko,j) .LT. zap_close_levels ) .AND. & ( ko .LT. generic ) ) THEN zap = zap + 1 zap_above = zap_above + 1 CYCLE END IF ordered_porig(count) = porig(i,ko,j) ordered_forig(count) = forig(i,ko,j) count = count + 1 END DO END IF DO kn = kstart , kend ordered_pnew(kn) = pnew(i,kn,j) END DO IF ( ( use_levels_below_ground ) .AND. ( use_surface ) ) THEN count = 0 find_how_many_1 : DO ko = 1 , generic IF ( porig(i,generic,j) .EQ. ordered_porig(ko) ) THEN count = count + 1 EXIT find_how_many_1 ELSE count = count + 1 END IF END DO find_how_many_1 kinterp_start = 1 kinterp_end = kinterp_start + count - 1 ELSE IF ( ( use_levels_below_ground ) .AND. ( .NOT. use_surface ) ) THEN count = 0 find_sfc_2 : DO ko = 1 , generic IF ( porig(i,1,j) .EQ. ordered_porig(ko) ) THEN sfc_level = ko EXIT find_sfc_2 END IF END DO find_sfc_2 DO ko = sfc_level , generic-1 ordered_porig(ko) = ordered_porig(ko+1) ordered_forig(ko) = ordered_forig(ko+1) END DO ordered_porig(generic) = 1.E-5 ordered_forig(generic) = 1.E10 count = 0 find_how_many_2 : DO ko = 1 , generic IF ( porig(i,generic,j) .EQ. ordered_porig(ko) ) THEN count = count + 1 EXIT find_how_many_2 ELSE count = count + 1 END IF END DO find_how_many_2 kinterp_start = 1 kinterp_end = kinterp_start + count - 1 ELSE IF ( ( .NOT. use_levels_below_ground ) .AND. ( use_surface ) ) THEN kcount = ko_above_sfc(i)-1-zap_below count = 0 DO ko = 1 , generic IF ( porig(i,ko,j) .EQ. ordered_porig(kcount) ) THEN kcount = kcount + 1 count = count + 1 ELSE END IF END DO kinterp_start = ko_above_sfc(i)-1-zap_below kinterp_end = kinterp_start + count - 1 END IF IF ( ( flag_maxw .EQ. 1 ) .AND. ( porig_maxw(i,j) .LE. maxw_above_this_level ) ) then ok_data = .TRUE. DO jj = -2, 2 DO ii = -2, 2 ok_data = ok_data .AND. & ( 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)) & .LT. maxw_horiz_pres_diff ) END DO END DO IF ( ok_data) THEN insert_maxw : DO ko = kinterp_start , kinterp_end-1 IF ( ( ( ordered_porig(ko)-porig_maxw(i,j) ) * ( ordered_porig(ko+1)-porig_maxw(i,j) ) ) .LT. 0 ) THEN IF ( ( ABS(ordered_porig(ko )-porig_maxw(i,j)) .GT. zap_close_extra_levels ) .AND. & ( ABS(ordered_porig(ko+1)-porig_maxw(i,j)) .GT. zap_close_extra_levels ) ) THEN DO kcount = kinterp_end , ko+1 , -1 ordered_porig(kcount+1) = ordered_porig(kcount) ordered_forig(kcount+1) = ordered_forig(kcount) END DO ordered_porig(ko+1) = porig_maxw(i,j) ordered_forig(ko+1) = fo_maxw(i,j) kinterp_end = kinterp_end + 1 EXIT insert_maxw ELSE IF ( ABS(ordered_porig(ko )-porig_maxw(i,j)) .LE. zap_close_extra_levels ) THEN ordered_porig(ko) = porig_maxw(i,j) ordered_forig(ko) = fo_maxw(i,j) EXIT insert_maxw ELSE IF ( ABS(ordered_porig(ko+1)-porig_maxw(i,j)) .LE. zap_close_extra_levels ) THEN ordered_porig(ko+1) = porig_maxw(i,j) ordered_forig(ko+1) = fo_maxw(i,j) EXIT insert_maxw END IF END IF END DO insert_maxw END IF END IF IF ( flag_trop .EQ. 1 ) THEN ok_data = .TRUE. DO jj = -2, 2 DO ii = -2, 2 ok_data = ok_data .AND. & ( 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)) & .LT. trop_horiz_pres_diff ) END DO END DO IF ( ok_data) THEN insert_trop : DO ko = kinterp_start , kinterp_end-1 IF ( ( ( ordered_porig(ko)-porig_trop(i,j) ) * ( ordered_porig(ko+1)-porig_trop(i,j) ) ) .LT. 0 ) THEN IF ( ( ABS(ordered_porig(ko )-porig_trop(i,j)) .GT. zap_close_extra_levels ) .AND. & ( ABS(ordered_porig(ko+1)-porig_trop(i,j)) .GT. zap_close_extra_levels ) ) THEN DO kcount = kinterp_end , ko+1 , -1 ordered_porig(kcount+1) = ordered_porig(kcount) ordered_forig(kcount+1) = ordered_forig(kcount) END DO ordered_porig(ko+1) = porig_trop(i,j) ordered_forig(ko+1) = fo_trop(i,j) kinterp_end = kinterp_end + 1 EXIT insert_trop ELSE IF ( ABS(ordered_porig(ko )-porig_trop(i,j)) .LE. zap_close_extra_levels ) THEN ordered_porig(ko) = porig_trop(i,j) ordered_forig(ko) = fo_trop(i,j) EXIT insert_trop ELSE IF ( ABS(ordered_porig(ko+1)-porig_trop(i,j)) .LE. zap_close_extra_levels ) THEN ordered_porig(ko+1) = porig_trop(i,j) ordered_forig(ko+1) = fo_trop(i,j) EXIT insert_trop END IF END IF END DO insert_trop END IF END IF outer : DO ko = kinterp_start , kinterp_end-1 IF ( ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .LT. MAX(zap_close_levels/10,50.) ) .AND. & ( ordered_porig(ko) .GT. zap_close_levels * 10 ) ) THEN WRITE ( message , FMT='(a,I2.2,a,F9.2,a,F9.2,a,i4,a,i4,a,a)' ) '*** -> Check your wrfinput_d',id, & ' file, you might have input pressure levels too close together (',& ordered_porig(ko),' Pa and ', ordered_porig(ko+1), & ' Pa) at (',i,',',j,') for variable type ',var_type CALL wrf_message ( TRIM(message) ) EXIT outer END IF END DO outer IF ( interp_type .EQ. 1 ) THEN CALL lagrange_setup ( var_type , interp_type , & ordered_porig(kinterp_start:kinterp_end) , & ordered_forig(kinterp_start:kinterp_end) , & kinterp_end-kinterp_start+1 , lagrange_order , extrap_type , & ordered_pnew(kstart:kend) , ordered_fnew , kend-kstart+1 ,i,j) ELSE CALL lagrange_setup ( var_type , interp_type , & LOG(ordered_porig(kinterp_start:kinterp_end)) , & ordered_forig(kinterp_start:kinterp_end) , & kinterp_end-kinterp_start+1 , lagrange_order , extrap_type , & LOG(ordered_pnew(kstart:kend)) , ordered_fnew , kend-kstart+1 ,i,j) END IF DO kn = kstart , kend fnew(i,kn,j) = ordered_fnew(kn) END DO IF ( lowest_lev_from_sfc ) THEN fnew(i,1,j) = forig(i,1,j) END IF END DO END DO END SUBROUTINE vert_interp SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n , extrap_type , & target_x , target_y , target_dim ,i,j) IMPLICIT NONE CHARACTER (LEN=1) :: var_type INTEGER , INTENT(IN) :: interp_type , all_dim , n , extrap_type , target_dim REAL, DIMENSION(all_dim) , INTENT(IN) :: all_x , all_y REAL , DIMENSION(target_dim) , INTENT(IN) :: target_x REAL , DIMENSION(target_dim) , INTENT(OUT) :: target_y INTEGER :: K REAL :: DX, ALPHA, BETA, GAMMA, ETA REAL , DIMENSION(all_dim) :: P2 INTEGER , INTENT(IN) :: i,j REAL , DIMENSION(n+1) :: x , y REAL :: a , b REAL :: target_y_1 , target_y_2 LOGICAL :: found_loc INTEGER :: loop , loc_center_left , loc_center_right , ist , iend , target_loop INTEGER :: vboundb , vboundt REAL :: temp_1 , temp_2 , temp_3 , temp_y REAL :: depth_of_extrap_in_p , avg_of_extrap_p , temp_extrap_starting_point , dhdp , dh , dt REAL , PARAMETER :: RovCp = rcp REAL , PARAMETER :: CRC_const1 = 11880.516 REAL , PARAMETER :: CRC_const2 = 0.1902632 REAL , PARAMETER :: CRC_const3 = 0.0065 REAL, DIMENSION(all_dim) :: all_x_full REAL , DIMENSION(target_dim) :: target_x_full IF ( all_dim .LT. n+1 ) THEN print *,'all_dim = ',all_dim print *,'order = ',n print *,'i,j = ',i,j print *,'p array = ',all_x print *,'f array = ',all_y print *,'p target= ',target_x CALL wrf_message ( 0 , 'Troubles, the interpolating order is too large for this few input values' ) CALL wrf_message ( 0 , 'This is usually caused by bad pressures' ) CALL wrf_message ( 0 , 'At this (i,j), look at the input value of pressure from metgrid' ) CALL wrf_message ( 0 , 'The surface pressure and the sea-level pressure should be reviewed, also from metgrid' ) CALL wrf_message ( 0 , 'Finally, ridiculous values of moisture can mess up the vertical pressures, especially aloft' ) CALL wrf_message ( 0 , 'The variable type is ' // var_type // '. This is not a unique identifer, but a type of field' ) CALL wrf_message ( 0 , 'Check to see if all time periods with this data fail, or just this one' ) CALL wrf_error_fatal3("",6224,& 'This vertical interpolation failure is more typically associated with untested data sources to ungrib' ) END IF IF ( n .LT. 1 ) THEN CALL wrf_error_fatal3("",6229,& 'pal, linear is about as low as we go' ) END IF vboundb = 4 vboundt = 0 DO target_loop = 1 , target_dim found_loc = .FALSE. find_trap : DO loop = 1 , all_dim -1 a = target_x(target_loop) - all_x(loop) b = target_x(target_loop) - all_x(loop+1) IF ( a*b .LE. 0.0 ) THEN loc_center_left = loop loc_center_right = loop+1 found_loc = .TRUE. EXIT find_trap END IF END DO find_trap IF ( ( .NOT. found_loc ) .AND. ( target_x(target_loop) .GT. all_x(1) ) ) THEN IF ( interp_type .EQ. 1 ) THEN all_x_full = all_x target_x_full = target_x ELSE all_x_full = EXP ( all_x ) target_x_full = EXP ( target_x ) END IF IF ( ( extrap_type .EQ. 1 ) .AND. ( var_type .EQ. 'T' ) ) THEN temp_1 = all_y(1) * ( all_x_full(1) / 100000. ) ** RovCp target_y(target_loop) = temp_1 * ( 100000. / target_x_full(target_loop) ) ** RovCp ELSE IF ( ( extrap_type .EQ. 2 ) .AND. ( var_type .EQ. 'T' ) ) THEN depth_of_extrap_in_p = target_x_full(target_loop) - all_x_full(1) avg_of_extrap_p = ( target_x_full(target_loop) + all_x_full(1) ) * 0.5 temp_extrap_starting_point = all_y(1) * ( all_x_full(1) / 100000. ) ** RovCp dhdp = CRC_const1 * CRC_const2 * ( avg_of_extrap_p / 100. ) ** ( CRC_const2 - 1. ) dh = dhdp * ( depth_of_extrap_in_p / 100. ) dt = dh * CRC_const3 target_y(target_loop) = ( temp_extrap_starting_point + dt ) * ( 100000. / target_x_full(target_loop) ) ** RovCp ELSE IF ( ( extrap_type .EQ. 3 ) .AND. ( var_type .EQ. 'T' ) ) THEN target_y(target_loop) = all_y(1) ELSE IF ( extrap_type .EQ. 1 ) THEN target_y(target_loop) = ( all_y(2) * ( target_x(target_loop) - all_x(3) ) + & all_y(3) * ( all_x(2) - target_x(target_loop) ) ) / & ( all_x(2) - all_x(3) ) ELSE IF ( extrap_type .EQ. 2 ) THEN target_y(target_loop) = all_y(1) ELSE IF ( extrap_type .EQ. 3 ) THEN CALL wrf_error_fatal3("",6310,& 'You are not allowed to use extrap_option #3 for any var except for theta.' ) END IF CYCLE ELSE IF ( .NOT. found_loc ) THEN print *,'i,j = ',i,j print *,'target pressure and value = ',target_x(target_loop),target_y(target_loop) DO loop = 1 , all_dim print *,'column of pressure and value = ',all_x(loop),all_y(loop) END DO CALL wrf_error_fatal3("",6321,& 'troubles, could not find trapping x locations' ) END IF IF ( n .EQ. 9 ) THEN CALL cubic_spline (all_dim-1, all_x, all_y, P2) DX = all_x(loc_center_right) - all_x(loc_center_left) ALPHA = P2(loc_center_right)/(6*DX) BETA = -P2(loc_center_left)/(6*DX) GAMMA = all_y(loc_center_right)/DX - DX*P2(loc_center_right)/6 ETA = DX*P2(loc_center_left)/6 - all_y(loc_center_left)/DX target_y(target_loop) = ALPHA*(target_x(target_loop)-all_x(loc_center_left))*(target_x(target_loop)-all_x(loc_center_left)) & *(target_x(target_loop)-all_x(loc_center_left)) & +BETA*(target_x(target_loop)-all_x(loc_center_right))*(target_x(target_loop)-all_x(loc_center_right)) & *(target_x(target_loop)-all_x(loc_center_right)) & +GAMMA*(target_x(target_loop)-all_x(loc_center_left)) & +ETA*(target_x(target_loop)-all_x(loc_center_right)) ELSE IF ( MOD(n,2) .NE. 0 ) THEN IF ( ( loc_center_left -(((n+1)/2)-1) .GE. 1 ) .AND. & ( loc_center_right+(((n+1)/2)-1) .LE. all_dim ) ) THEN ist = loc_center_left -(((n+1)/2)-1) iend = ist + n CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop) ) ELSE IF ( .NOT. found_loc ) THEN CALL wrf_error_fatal3("",6354,& 'I doubt this will happen, I will only do 2nd order for now' ) END IF END IF ELSE IF ( ( MOD(n,2) .EQ. 0 ) .AND. & ( ( target_loop .GE. 1 + vboundb ) .AND. ( target_loop .LE. target_dim - vboundt ) ) ) THEN IF ( ( loc_center_left -(((n )/2)-1) .GE. 1 ) .AND. & ( loc_center_right+(((n )/2) ) .LE. all_dim ) .AND. & ( loc_center_left -(((n )/2) ) .GE. 1 ) .AND. & ( loc_center_right+(((n )/2)-1) .LE. all_dim ) ) THEN ist = loc_center_left -(((n )/2)-1) iend = ist + n CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y_1 ) ist = loc_center_left -(((n )/2) ) iend = ist + n CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y_2 ) target_y(target_loop) = ( target_y_1 + target_y_2 ) * 0.5 ELSE IF ( ( loc_center_left -(((n )/2)-1) .GE. 1 ) .AND. & ( loc_center_right+(((n )/2) ) .LE. all_dim ) ) THEN ist = loc_center_left -(((n )/2)-1) iend = ist + n CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop) ) ELSE IF ( ( loc_center_left -(((n )/2) ) .GE. 1 ) .AND. & ( loc_center_right+(((n )/2)-1) .LE. all_dim ) ) THEN ist = loc_center_left -(((n )/2) ) iend = ist + n CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , n , target_x(target_loop) , target_y(target_loop) ) ELSE CALL wrf_error_fatal3("",6384,& 'unauthorized area, you should not be here' ) END IF ELSE IF ( MOD(n,2) .EQ. 0 ) THEN ist = loc_center_left iend = loc_center_right CALL lagrange_interp ( all_x(ist:iend) , all_y(ist:iend) , 1 , target_x(target_loop) , target_y(target_loop) ) END IF END DO END SUBROUTINE lagrange_setup SUBROUTINE cubic_spline (N, XI, FI, P2) INTEGER :: I INTEGER, INTENT (IN) :: N REAL, INTENT (IN), DIMENSION (N+1):: XI, FI REAL, INTENT (OUT), DIMENSION (N+1):: P2 REAL, DIMENSION (N):: G, H REAL, DIMENSION (N-1):: D, B, C DO I = 1, N H(I) = XI(I+1) - XI(I) G(I) = FI(I+1) - FI(I) END DO DO I = 1, N-1 D(I) = 2*(H(I+1)+H(I)) B(I) = 6*(G(I+1)/H(I+1)-G(I)/H(I)) C(I) = H(I+1) END DO CALL TRIDIAGONAL_LINEAR_EQ (N-1, D, C, C, B, G) P2(1) = 0 P2(N+1) = 0 DO I = 2, N P2(I) = G(I-1) END DO END SUBROUTINE cubic_spline SUBROUTINE TRIDIAGONAL_LINEAR_EQ (L, D, E, C, B, Z) INTEGER, INTENT (IN) :: L INTEGER :: I REAL, INTENT (IN), DIMENSION (L):: D, E, C, B REAL, INTENT (OUT), DIMENSION (L):: Z REAL, DIMENSION (L):: Y, W REAL, DIMENSION (L-1):: V, T W(1) = D(1) V(1) = C(1) T(1) = E(1)/W(1) DO I = 2, L - 1 W(I) = D(I)-V(I-1)*T(I-1) V(I) = C(I) T(I) = E(I)/W(I) END DO W(L) = D(L)-V(L-1)*T(L-1) Y(1) = B(1)/W(1) DO I = 2, L Y(I) = (B(I)-V(I-1)*Y(I-1))/W(I) END DO Z(L) = Y(L) DO I = L-1, 1, -1 Z(I) = Y(I) - T(I)*Z(I+1) END DO END SUBROUTINE TRIDIAGONAL_LINEAR_EQ SUBROUTINE lagrange_interp ( x , y , n , target_x , target_y ) IMPLICIT NONE INTEGER , INTENT(IN) :: n REAL , DIMENSION(0:n) , INTENT(IN) :: x , y REAL , INTENT(IN) :: target_x REAL , INTENT(OUT) :: target_y INTEGER :: i , k REAL :: numer , denom , Px REAL , DIMENSION(0:n) :: Ln Px = 0. DO i = 0 , n numer = 1. denom = 1. DO k = 0 , n IF ( k .EQ. i ) CYCLE numer = numer * ( target_x - x(k) ) denom = denom * ( x(i) - x(k) ) END DO IF ( denom .NE. 0. ) THEN Ln(i) = y(i) * numer / denom Px = Px + Ln(i) ENDIF END DO target_y = Px END SUBROUTINE lagrange_interp SUBROUTINE p_dry ( mu0 , eta , pdht , pdry , full_levs , & c3f , c3h , c4f , c4h , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte LOGICAL :: full_levs REAL , DIMENSION(ims:ime, jms:jme) , INTENT(IN) :: mu0 REAL , DIMENSION( kms:kme ) , INTENT(IN) :: eta REAL , DIMENSION( kms:kme ) , INTENT(IN) :: c3f , c3h , c4f , c4h REAL :: pdht REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: pdry INTEGER :: i , j , k REAL , DIMENSION( kms:kme ) :: eta_h IF ( full_levs ) THEN DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pdry(i,k,j) = c3f(k) * MU0(i,j) + c4f(k) + pdht END DO END DO END DO ELSE DO k = kts , kte-1 eta_h(k) = ( eta(k) + eta(k+1) ) * 0.5 END DO DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte-1 DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pdry(i,k,j) = c3h(k) * MU0(i,j) + c4h(k) + pdht END DO END DO END DO END IF END SUBROUTINE p_dry SUBROUTINE p_dts ( pdts , intq , psfc , p_top , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , INTENT(IN) :: p_top REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: psfc REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: intq REAL , DIMENSION(ims:ime,jms:jme) , INTENT(OUT) :: pdts INTEGER :: i , j , k DO j = jts , MIN ( jde-1 , jte ) DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pdts(i,j) = psfc(i,j) - intq(i,j) - p_top END DO END DO END SUBROUTINE p_dts SUBROUTINE p_dhs ( pdhs , ht , p0 , t0 , a , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , DIMENSION(ims:ime, jms:jme) , INTENT(IN) :: ht REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: pdhs REAL , INTENT(IN) :: p0 , t0 , a INTEGER :: i , j , k REAL , PARAMETER :: Rd = r_d DO j = jts , MIN ( jde-1 , jte ) DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pdhs(i,j) = p0 * EXP ( -t0/a + SQRT ( (t0/a)**2 - 2. * g * ht(i,j)/(a * Rd) ) ) END DO END DO END SUBROUTINE p_dhs SUBROUTINE find_p_top ( p , p_top , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL :: p_top REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p INTEGER :: i , j , k, min_lev i = its j = jts p_top = p(i,2,j) min_lev = 2 DO k = 2 , kte IF ( p_top .GT. p(i,k,j) ) THEN p_top = p(i,k,j) min_lev = k END IF END DO k = min_lev p_top = p(its,k,jts) DO j = jts , MIN ( jde-1 , jte ) DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE p_top = MAX ( p_top , p(i,k,j) ) END DO END DO END SUBROUTINE find_p_top SUBROUTINE t_to_theta ( t , p , p00 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , INTENT(IN) :: p00 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: t INTEGER :: i , j , k REAL , PARAMETER :: Rd = r_d DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE t(i,k,j) = t(i,k,j) * ( p00 / p(i,k,j) ) ** (Rd / Cp) END DO END DO END DO END SUBROUTINE t_to_theta SUBROUTINE theta_to_t ( t , p , p00 , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , INTENT(IN) :: p00 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: t INTEGER :: i , j , k REAL , PARAMETER :: Rd = r_d CHARACTER (LEN=80) :: mess DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte-1 DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE if ( p(i,k,j) .NE. 0. ) then t(i,k,j) = t(i,k,j) / ( ( p00 / p(i,k,j) ) ** (Rd / Cp) ) else WRITE(mess,*) 'Troubles in theta_to_t' CALL wrf_debug(0,mess) WRITE(mess,*) "i,j,k = ", i,j,k CALL wrf_debug(0,mess) WRITE(mess,*) "p(i,k,j) = ", p(i,k,j) CALL wrf_debug(0,mess) WRITE(mess,*) "t(i,k,j) = ", t(i,k,j) CALL wrf_debug(0,mess) endif END DO END DO END DO END SUBROUTINE theta_to_t SUBROUTINE integ_moist ( q_in , p_in , pd_out , t_in , ght_in , intq , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: q_in , p_in , t_in , ght_in REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: pd_out REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: intq INTEGER :: i , j , k INTEGER , DIMENSION(ims:ime) :: level_above_sfc REAL , DIMENSION(ims:ime,jms:jme) :: psfc , tsfc , qsfc, zsfc REAL , DIMENSION(ims:ime,kms:kme) :: q , p , t , ght, pd REAL :: rhobar , qbar , dz REAL :: p1 , p2 , t1 , t2 , q1 , q2 , z1, z2 LOGICAL :: upside_down LOGICAL :: already_assigned_upside_down REAL , PARAMETER :: Rd = r_d already_assigned_upside_down = .FALSE. find_valid : DO j = jts , MIN ( jde-1 , jte ) DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( p_in(i,kts+1,j) .LT. p_in(i,kte,j) ) THEN upside_down = .TRUE. already_assigned_upside_down = .TRUE. ELSE upside_down = .FALSE. already_assigned_upside_down = .TRUE. END IF EXIT find_valid END DO END DO find_valid IF ( .NOT. already_assigned_upside_down ) THEN upside_down = .FALSE. END IF DO j = jts , MIN ( jde-1 , jte ) DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE psfc(i,j) = p_in(i,kts,j) tsfc(i,j) = t_in(i,kts,j) qsfc(i,j) = q_in(i,kts,j) zsfc(i,j) = ght_in(i,kts,j) END DO END DO DO j = jts , MIN ( jde-1 , jte ) DO i = its , MIN (ide-1 , ite ) intq(i,j) = 0. END DO IF ( upside_down ) THEN DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE p(i,kts) = p_in(i,kts,j) t(i,kts) = t_in(i,kts,j) q(i,kts) = q_in(i,kts,j) ght(i,kts) = ght_in(i,kts,j) DO k = kts+1,kte p(i,k) = p_in(i,kte+2-k,j) t(i,k) = t_in(i,kte+2-k,j) q(i,k) = q_in(i,kte+2-k,j) ght(i,k) = ght_in(i,kte+2-k,j) END DO END DO ELSE DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE DO k = kts,kte p(i,k) = p_in(i,k ,j) t(i,k) = t_in(i,k ,j) q(i,k) = q_in(i,k ,j) ght(i,k) = ght_in(i,k ,j) END DO END DO END IF DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE level_above_sfc(i) = -1 IF ( p(i,kts+1) .LT. psfc(i,j) ) THEN level_above_sfc(i) = kts+1 ELSE find_k : DO k = kts+1,kte-1 IF ( ( p(i,k )-psfc(i,j) .GE. 0. ) .AND. & ( p(i,k+1)-psfc(i,j) .LT. 0. ) ) THEN level_above_sfc(i) = k+1 EXIT find_k END IF END DO find_k IF ( level_above_sfc(i) .EQ. -1 ) THEN print *,'i,j = ',i,j print *,'p = ',p(i,:) print *,'p sfc = ',psfc(i,j) CALL wrf_error_fatal3("",6905,& 'Could not find level above ground') END IF END IF END DO DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pd(i,kte) = p(i,kte) DO k = kte-1,level_above_sfc(i),-1 rhobar = ( p(i,k ) / ( Rd * t(i,k ) ) + & p(i,k+1) / ( Rd * t(i,k+1) ) ) * 0.5 qbar = ( q(i,k ) + q(i,k+1) ) * 0.5 dz = ght(i,k+1) - ght(i,k) intq(i,j) = intq(i,j) + g * qbar * rhobar / (1. + qbar) * dz pd(i,k) = p(i,k) - intq(i,j) END DO IF ( ( p(i,level_above_sfc(i)-1)-psfc(i,j) .GE. 0. ) .AND. & ( p(i,level_above_sfc(i) )-psfc(i,j) .LT. 0. ) .AND. & ( level_above_sfc(i) .GT. kts ) ) THEN p1 = psfc(i,j) p2 = p(i,level_above_sfc(i)) t1 = tsfc(i,j) t2 = t(i,level_above_sfc(i)) q1 = qsfc(i,j) q2 = q(i,level_above_sfc(i)) z1 = zsfc(i,j) z2 = ght(i,level_above_sfc(i)) rhobar = ( p1 / ( Rd * t1 ) + & p2 / ( Rd * t2 ) ) * 0.5 qbar = ( q1 + q2 ) * 0.5 dz = z2 - z1 IF ( dz .GT. 0.1 ) THEN intq(i,j) = intq(i,j) + g * qbar * rhobar / (1. + qbar) * dz END IF DO k = level_above_sfc(i)-1,kts+1,-1 pd(i,k) = p(i,k) - intq(i,j) END DO END IF pd(i,kts) = psfc(i,j) - intq(i,j) END DO IF ( upside_down ) THEN DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pd_out(i,kts,j) = pd(i,kts) DO k = kts+1,kte pd_out(i,kte+2-k,j) = pd(i,k) END DO END DO ELSE DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE DO k = kts,kte pd_out(i,k,j) = pd(i,k) END DO END DO END IF END DO END SUBROUTINE integ_moist SUBROUTINE rh_to_mxrat2(rh, t, p, q , wrt_liquid , & qv_max_p_safe , & qv_max_flag , qv_max_value , & qv_min_p_safe , & qv_min_flag , qv_min_value , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte LOGICAL , INTENT(IN) :: wrt_liquid REAL , INTENT(IN) :: qv_max_p_safe , qv_max_flag , qv_max_value REAL , INTENT(IN) :: qv_min_p_safe , qv_min_flag , qv_min_value REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p , t REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: rh REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: q REAL, PARAMETER :: T0K = 273.16 REAL, PARAMETER :: Tice = T0K - 23.0 REAL, PARAMETER :: cfe = 1.0/(23.0*23.0) REAL, PARAMETER :: eps = 0.622 REAL, PARAMETER :: cw1 = 10.79574 REAL, PARAMETER :: cw2 = -5.02800 REAL, PARAMETER :: cw3 = 1.50475E-4 REAL, PARAMETER :: cw4 = 0.42873E-3 REAL, PARAMETER :: cw5 = 0.78614 REAL, PARAMETER :: ci1 = -9.09685 REAL, PARAMETER :: ci2 = -3.56654 REAL, PARAMETER :: ci3 = 0.87682 REAL, PARAMETER :: ci4 = 0.78614 REAL, PARAMETER :: Tn = 273.16 REAL, PARAMETER :: QV_MIN = 1.e-6 REAL, PARAMETER :: QV_MAX = 0.045 REAL, PARAMETER :: EP_MAX = QV_MAX/(eps+QV_MAX) INTEGER :: i , j , k REAL :: ew , q1 , t1 REAL :: ta, tb, pw3, pw4, pwr REAL :: es, esw, esi, wvp, pmb, wvpmax DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE rh(i,k,j) = MIN ( MAX ( rh(i,k,j) , 0. ) , 100. ) END DO END DO END DO IF ( wrt_liquid ) THEN DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE Ta=Tn/T(i,k,j) Tb=T(i,k,j)/Tn pw3 = -8.2969*(Tb-1.0) pw4 = 4.76955*(1.0-Ta) pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5 es = 10.0**pwr wvp = 0.01*rh(i,k,j)*es pmb = p(i,k,j)/100. wvpmax = EP_MAX*pmb wvp = MIN(wvp,wvpmax) q(i,k,j) = eps*wvp/(pmb-wvp) END DO END DO END DO ELSE DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE Ta=Tn/T(i,k,j) Tb=T(i,k,j)/Tn IF (t(i,k,j) >= T0K) THEN pw3 = -8.2969*(Tb-1.0) pw4 = 4.76955*(1.0-Ta) pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5 es = 10.0**pwr wvp = 0.01*rh(i,k,j)*es ELSE IF (t(i,k,j) <= Tice) THEN pwr = ci1*(Ta-1.0) + ci2*LOG10(Ta) + ci3*(1.0-Tb) + ci4 es = 10.0**pwr wvp = 0.01*rh(i,k,j)*es ELSE pw3 = -8.2969*(Tb-1.0) pw4 = 4.76955*(1.0-Ta) pwr = cw1*(1.0-Ta) + cw2*LOG10(Tb) + cw3*(1.0-10.0**pw3) + cw4*(10.0**pw4-1.0) + cw5 esw = 10.0**pwr pwr = ci1*(Ta-1.0) + ci2*LOG10(Ta) + ci3*(1.0-Tb) + ci4 esi = 10.0**pwr es = esi + (esw-esi)*cfe*(T(i,k,j)-Tice)*(T(i,k,j)-Tice) wvp = 0.01*rh(i,k,j)*es END IF pmb = p(i,k,j)/100. wvpmax = EP_MAX*pmb wvp = MIN(wvp,wvpmax) q(i,k,j) = eps*wvp/(pmb-wvp) END DO END DO END DO END IF DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( p(i,k,j) .LT. qv_max_p_safe ) THEN IF ( q(i,k,j) .GT. qv_max_flag ) THEN q(i,k,j) = qv_max_value END IF END IF IF ( p(i,k,j) .LT. qv_min_p_safe ) THEN IF ( q(i,k,j) .LT. qv_min_flag ) THEN q(i,k,j) = qv_min_value END IF END IF END DO END DO END DO END SUBROUTINE rh_to_mxrat2 SUBROUTINE rh_to_mxrat1(rh, t, p, q , wrt_liquid , & qv_max_p_safe , & qv_max_flag , qv_max_value , & qv_min_p_safe , & qv_min_flag , qv_min_value , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte LOGICAL , INTENT(IN) :: wrt_liquid REAL , INTENT(IN) :: qv_max_p_safe , qv_max_flag , qv_max_value REAL , INTENT(IN) :: qv_min_p_safe , qv_min_flag , qv_min_value REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: p , t REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: rh REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: q INTEGER :: i , j , k REAL :: ew , q1 , t1 REAL, PARAMETER :: T_REF = 0.0 REAL, PARAMETER :: MW_AIR = 28.966 REAL, PARAMETER :: MW_VAP = 18.0152 REAL, PARAMETER :: A0 = 6.107799961 REAL, PARAMETER :: A1 = 4.436518521e-01 REAL, PARAMETER :: A2 = 1.428945805e-02 REAL, PARAMETER :: A3 = 2.650648471e-04 REAL, PARAMETER :: A4 = 3.031240396e-06 REAL, PARAMETER :: A5 = 2.034080948e-08 REAL, PARAMETER :: A6 = 6.136820929e-11 REAL, PARAMETER :: ES0 = 6.1121 REAL, PARAMETER :: C1 = 9.09718 REAL, PARAMETER :: C2 = 3.56654 REAL, PARAMETER :: C3 = 0.876793 REAL, PARAMETER :: EIS = 6.1071 REAL :: RHS REAL, PARAMETER :: TF = 273.16 REAL :: TK REAL :: ES REAL :: QS REAL, PARAMETER :: EPS = 0.622 REAL, PARAMETER :: SVP1 = 0.6112 REAL, PARAMETER :: SVP2 = 17.67 REAL, PARAMETER :: SVP3 = 29.65 REAL, PARAMETER :: SVPT0 = 273.15 CHARACTER (LEN=80) :: mess DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE rh(i,k,j) = MIN ( MAX ( rh(i,k,j) , 0. ) , 100. ) END DO END DO END DO IF ( wrt_liquid ) THEN DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE if (t(i,k,j) .ne. 0.) then es=.01*rh(i,k,j)*svp1*10.*EXP(svp2*(t(i,k,j)-svpt0)/(t(i,k,j)-svp3)) IF (es .ge. p(i,k,j)/100.)THEN q(i,k,j)=1.E-6 WRITE(mess,*) 'Warning: vapor pressure exceeds total pressure, setting Qv to 1.E-6' CALL wrf_debug(1,mess) ELSE q(i,k,j)=MAX(eps*es/(p(i,k,j)/100.-es),1.E-6) ENDIF else q(i,k,j)=1.E-6 WRITE(mess,*) 't(i,j,k) was 0 at ', i,j,k,', setting Qv to 0' CALL wrf_debug(0,mess) endif END DO END DO END DO ELSE DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE t1 = t(i,k,j) - 273.16 IF ( t1 .lt. -200. ) THEN q(i,k,j) = 0 ELSE IF ( t1 .GE. t_ref ) THEN ew = a0 + t1 * (a1 + t1 * (a2 + t1 * (a3 + t1 * (a4 + t1 * (a5 + t1 * a6))))) ELSE IF ( ( t1 .LT. t_ref ) .AND. ( t1 .GE. -47. ) ) THEN ew = es0 * exp(17.67 * t1 / ( t1 + 243.5)) ELSE IF ( t1 .LT. -47. ) THEN tk = t(i,k,j) rhs = -c1 * (tf / tk - 1.) - c2 * alog10(tf / tk) + & c3 * (1. - tk / tf) + alog10(eis) ew = 10. ** rhs END IF ew = MAX ( ew , 0. ) * rh(i,k,j) * 0.01 q1 = mw_vap * ew q1 = q1 / (q1 + mw_air * (p(i,k,j)/100. - ew)) q(i,k,j) = q1 / (1. - q1 ) END IF END DO END DO END DO END IF DO j = jts , MIN ( jde-1 , jte ) DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( p(i,k,j) .LT. qv_max_p_safe ) THEN IF ( q(i,k,j) .GT. qv_max_flag ) THEN q(i,k,j) = qv_max_value END IF END IF IF ( p(i,k,j) .LT. qv_min_p_safe ) THEN IF ( q(i,k,j) .LT. qv_min_flag ) THEN q(i,k,j) = qv_min_value END IF END IF END DO END DO END DO END SUBROUTINE rh_to_mxrat1 SUBROUTINE compute_eta ( znw , auto_levels_opt , & eta_levels , max_eta , max_dz , dzbot , dzstretch_s , dzstretch_u , & p_top , g , p00 , cvpm , a , r_d , cp , & t00 , p1000mb , t0 , tiso , p_strat , a_strat , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , INTENT(IN) :: max_dz, dzbot, dzstretch_s, dzstretch_u REAL , INTENT(IN) :: p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 , tiso REAL , INTENT(IN) :: p_strat , a_strat INTEGER , INTENT(IN) :: max_eta, auto_levels_opt REAL , DIMENSION (max_eta) :: eta_levels REAL , DIMENSION (kts:kte) , INTENT(OUT) :: znw INTEGER :: k , kk REAL(KIND=8) :: mub , t_init , p_surf , pb, ztop, ztop_pbl , dz , temp REAL(KIND=8) , DIMENSION(kts:kte) :: dnw INTEGER , PARAMETER :: prac_levels = 59 INTEGER :: loop , loop1 REAL(KIND=8) , DIMENSION(prac_levels) :: znw_prac , znu_prac , dnw_prac REAL(KIND=8) , DIMENSION(MAX(prac_levels,kde)) :: alb , phb REAL(KIND=8) :: alb_max, t_init_max, pb_max, phb_max REAL(KIND=8) :: p00_r8, t00_r8, a_r8, tiso_r8 CHARACTER(LEN=256) :: message IF ( ABS(eta_levels(1)+1.) .GT. 0.0000001 ) THEN IF ( ( ABS(eta_levels(1 )-1.) .LT. 0.0000001 ) .AND. & ( ABS(eta_levels(kde)-0.) .LT. 0.0000001 ) ) THEN DO k = kds+1 , kde-1 znw(k) = eta_levels(k) END DO znw( 1) = 1. znw(kde) = 0. ELSE IF ( ( ABS(eta_levels(kde)-1.) .LT. 0.0000001 ) .AND. & ( ABS(eta_levels(1 )-0.) .LT. 0.0000001 ) ) THEN DO k = kds+1 , kde-1 znw(k) = eta_levels(kde+1-k) END DO znw( 1) = 1. znw(kde) = 0. ELSE CALL wrf_error_fatal3("",7397,& 'First eta level should be 1.0 and the last 0.0 in namelist' ) END IF DO k = kds , kde-1 IF ( znw(k) .LE. znw(k+1) ) THEN PRINT *,'eta on full levels is not monotonic' PRINT *,'eta (',k,') = ',znw(k) PRINT *,'eta (',k+1,') = ',znw(k+1) CALL wrf_error_fatal3("",7408,& 'Fix non-monotonic "eta_levels" in the namelist.input file' ) END IF END DO ELSE IF( auto_levels_opt == 1 ) THEN print *,'using old automatic levels program' p_surf = p00 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 , & 0.8500_8 , 0.8000_8 , 0.7500_8 , 0.7000_8 , 0.6500_8 , 0.6000_8 , 0.5500_8 , 0.5000_8 , & 0.4500_8 , 0.4000_8 , 0.3500_8 , 0.3000_8 , 0.2500_8 , 0.2000_8 , 0.1500_8 , 0.1000_8 , & 0.0800_8 , 0.0600_8 , 0.0400_8 , 0.0200_8 , & 0.0150_8 , 0.0100_8 , 0.0090_8 , 0.0080_8 , 0.0070_8 , 0.0060_8 , 0.0050_8 , 0.0040_8 , & 0.0035_8 , 0.0030_8 , & 0.0028_8 , 0.0026_8 , 0.0024_8 , 0.0022_8 , 0.0020_8 , & 0.0018_8 , 0.0016_8 , 0.0014_8 , 0.0012_8 , 0.0010_8 , & 0.0009_8 , 0.0008_8 , 0.0007_8 , 0.0006_8 , 0.0005_8 , 0.0004_8 , 0.0003_8 , & 0.0002_8 , 0.0001_8 , 0.00005_8, 0.0000_8 /) DO k = 1 , prac_levels - 1 znu_prac(k) = ( znw_prac(k) + znw_prac(k+1) ) * 0.5_8 dnw_prac(k) = znw_prac(k+1) - znw_prac(k) END DO tiso_r8 = tiso t00_r8 = t00 a_r8 = a p00_r8 = p00 DO k = 1, prac_levels-1 pb = znu_prac(k)*(p_surf - p_top) + p_top temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) IF ( pb .LT. p_strat ) THEN temp = tiso + A_strat*LOG(pb/p_strat) END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm END DO mub = p_surf - p_top phb(1) = 0._8 DO k = 2,prac_levels phb(k) = phb(k-1) - dnw_prac(k-1)*mub*alb(k-1) END DO ztop = phb(prac_levels) / g ztop_pbl = phb(8 ) / g dz = ( ztop - ztop_pbl ) / REAL ( kde - 8 ) IF ( dz .GE. max_dz ) THEN WRITE (message,FMT='("With a requested ",F7.1," Pa model top, the model lid will be about ",F7.1," m.")') p_top, ztop CALL wrf_message ( message ) WRITE (message,FMT='("With ",I3," levels above the PBL, the level thickness will be about ",F6.1," m.")') kde-8, dz CALL wrf_message ( message ) WRITE (message,FMT='("Thicknesses greater than ",F7.1," m are not recommended.")') max_dz CALL wrf_message ( message ) CALL wrf_error_fatal3("",7480,& 'Add more levels to namelist.input for e_vert' ) END IF DO k = 1 , 8 eta_levels(k) = znw_prac(k) END DO DO k = 8, kte-1-2 find_prac : DO kk = 1 , prac_levels IF (znw_prac(kk) .LT. eta_levels(k) ) THEN EXIT find_prac END IF end do find_prac pb = 0.5*(eta_levels(k)+znw_prac(kk)) * (p_surf - p_top) + p_top temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) IF ( pb .LT. p_strat ) THEN temp = tiso + A_strat * LOG ( pb/p_strat ) END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm eta_levels(k+1) = eta_levels(k) - dz*g / ( mub*alb(k) ) pb = 0.5*(eta_levels(k)+eta_levels(k+1)) * (p_surf - p_top) + p_top temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) IF ( pb .LT. p_strat ) THEN temp = tiso + A_strat * LOG ( pb/p_strat ) END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm eta_levels(k+1) = eta_levels(k) - dz*g / ( mub*alb(k) ) pb = 0.5*(eta_levels(k)+eta_levels(k+1)) * (p_surf - p_top) + p_top phb(k+1) = phb(k) - (eta_levels(k+1)-eta_levels(k)) * mub*alb(k) END DO alb_max = alb(kte-1-2) t_init_max = t_init pb_max = pb phb_max = phb(kte-1) DO k = 1 , kte-1-2 znw(k) = eta_levels(k) END DO znw(kte-2) = 0.000 DO loop1 = 1 , 5 DO loop = 1 , 10 DO k = 8, kte-1-2-1 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) IF ( pb .LT. p_strat ) THEN temp = tiso + A_strat * LOG ( pb/p_strat ) END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm znw(k+1) = znw(k) - dz*g / ( mub*alb(k) ) END DO pb = pb_max t_init = t_init_max alb(kte-1-2) = alb_max znw(kte-2) = znw(kte-1-2) - dz*g / ( mub*alb(kte-1-2) ) IF ( ( loop1 .EQ. 5 ) .AND. ( loop .EQ. 10 ) ) THEN print *,'Converged znw(kte) should be about 0.0 = ',znw(kte-2) END IF znw(kte-2) = 0.000 END DO DO k = 1, kde-1-2 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) IF ( pb .LT. p_strat ) THEN temp = tiso + A_strat * LOG ( pb/p_strat ) END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm END DO phb(1) = 0. DO k = 2,kde-2 phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1) END DO ztop = phb(kde-2)/g ztop_pbl = phb(8)/g dz = ( ztop - ztop_pbl ) / REAL ( (kde-2) - 8 ) END DO IF ( dz .GT. max_dz ) THEN print *,'z (m) = ',phb(1)/g do k = 2 ,kte-2 print *,'z (m) and dz (m) = ',phb(k)/g,(phb(k)-phb(k-1))/g end do print *,'dz (m) above fixed eta levels = ',dz print *,'namelist max_dz (m) = ',max_dz print *,'namelist p_top (Pa) = ',p_top CALL wrf_debug ( 0, 'You need one of three things:' ) CALL wrf_debug ( 0, '1) More eta levels to reduce the dz: e_vert' ) CALL wrf_debug ( 0, '2) A lower p_top so your total height is reduced: p_top_requested') CALL wrf_debug ( 0, '3) Increase the maximum allowable eta thickness: max_dz') CALL wrf_debug ( 0, 'All are namelist options') CALL wrf_error_fatal3("",7602,& 'dz above fixed eta levels is too large') END IF DO k = kte-2 , 9 , -1 znw(k+2) = znw(k) END DO znw( 9) = 0.75 * znw( 8) + 0.25 * znw(12) znw(10) = 0.50 * znw( 8) + 0.50 * znw(12) znw(11) = 0.25 * znw( 8) + 0.75 * znw(12) DO k = 8, kte-1 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) IF ( pb .LT. p_strat ) THEN temp = tiso + A_strat * LOG ( pb/p_strat ) END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1) END DO phb(kte) = phb(kte-1) - (znw(kte)-znw(kte-1)) * mub*alb(kte-1) ELSE IF (auto_levels_opt == 2) THEN print *,'using new automatic levels program' CALL levels(kte-1, p_top, znw, max_dz, dzbot, dzstretch_s, dzstretch_u, r_d, g ) p_surf = p00 tiso_r8 = tiso t00_r8 = t00 a_r8 = a p00_r8 = p00 mub = p_surf - p_top phb(1) = 0. DO k = 1, kte-1 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) IF ( pb .LT. p_strat ) THEN temp = tiso + A_strat * LOG ( pb/p_strat ) END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm phb(k+1) = phb(k) - (znw(k+1)-znw(k)) * mub*alb(k) END DO ELSE print *,'auto_levels_opt=',auto_levels_opt CALL wrf_error_fatal3("",7656,& 'auto_levels_opt needs to be 1 or 2') ENDIF k=1 WRITE (*,FMT='("Full level index = ",I4," Height = ",F7.1," m")') k,phb(1)/g do k = 2 ,kte WRITE (*,FMT='("Full level index = ",I4," Height = ",F7.1," m Thickness = ",F6.1," m")') k,phb(k)/g,(phb(k)-phb(k-1))/g end do WRITE (*,FMT='("p_top = ",F7.0," Pa, dzbot = ",F6.1," m, dzstretch_s/u = ",2F6.2)') p_top,dzbot,dzstretch_s,dzstretch_u END IF END SUBROUTINE compute_eta SUBROUTINE levels ( nlev, ptop, eta, dzmax, dzbot, dzstretch_s, dzstretch_u, r_d, g ) implicit none integer, intent(in) :: nlev real, intent(in) :: ptop, dzmax, dzbot, dzstretch_s, dzstretch_u, r_d, g real, dimension(0:nlev), intent(out) :: eta real, dimension(nlev) :: zup, pup real :: tt, a real :: ztop, dz, dztest, zscale integer :: isave, i tt=290. ztop=r_d*tt/g*alog(1.e5/ptop) zscale=r_d*tt/g dz=dzbot zup(1)=dz pup(1)=1.e5*exp(-g*zup(1)/r_d/tt) eta(0)=1.0 eta(1)=(pup(1)-ptop)/(1.e5-ptop) print *,1,dz,zup(1),eta(1) isave=1 do i=1,nlev-1 a=dzstretch_u+(dzstretch_s-dzstretch_u)*max((dzmax*0.5-dz)/(dzmax*0.5), 0.) dz=a*dz dztest=(ztop-zup(isave))/(nlev-isave) if(dztest.lt.dz)exit isave=i+1 zup(i+1)=zup(i)+dz pup(i+1)=1.e5*exp(-g*zup(i+1)/r_d/tt) eta(i+1)=(pup(i+1)-ptop)/(1.e5-ptop) print *,i+1,dz,zup(i+1),eta(i+1),a IF ( i .EQ. nlev-1 ) THEN CALL wrf_debug ( 0, 'You need one of four things:' ) CALL wrf_debug ( 0, '1) More eta levels: e_vert' ) CALL wrf_debug ( 0, '2) A lower p_top: p_top_requested') CALL wrf_debug ( 0, '3) Increase the lowest eta thickness: dzbot') CALL wrf_debug ( 0, '4) Increase the stretching factor: dzstretch_s or dzstretch_u') CALL wrf_debug ( 0, 'All are namelist options') CALL wrf_error_fatal3("",7709,& 'not enough eta levels to reach p_top') END IF enddo print *,ztop,zup(isave),nlev,isave dz=(ztop-zup(isave))/(nlev-isave) IF ( dz .GT. 1.5*dzmax ) THEN CALL wrf_debug ( 0, 'Warning: Upper levels may be too thick' ) CALL wrf_debug ( 0, 'You need one of five things:' ) CALL wrf_debug ( 0, '1) More eta levels: e_vert' ) CALL wrf_debug ( 0, '2) A lower p_top: p_top_requested') CALL wrf_debug ( 0, '3) Increase the lowest eta thickness: dzbot') CALL wrf_debug ( 0, '4) Increase the stretching factor: dzstretch_s or dzstretch_u') CALL wrf_debug ( 0, '5) Increase the maximum allowed thickness: max_dz') CALL wrf_debug ( 0, 'All are namelist options') CALL wrf_error_fatal3("",7724,& 'Upper levels may be too thick') END IF do i=isave,nlev-1 zup(i+1)=zup(i)+dz pup(i+1)=1.e5*exp(-g*zup(i+1)/r_d/tt) eta(i+1)=(pup(i+1)-ptop)/(1.e5-ptop) print *,i+1,dz,zup(i+1),eta(i+1) enddo eta(nlev) = 0. print 1000, eta 1000 format(10f10.4) return END SUBROUTINE levels SUBROUTINE monthly_min_max ( field_in , field_min , field_max , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , DIMENSION(ims:ime,12,jms:jme) , INTENT(IN) :: field_in REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_min , field_max INTEGER :: i , j , l REAL :: minner , maxxer DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) minner = field_in(i,1,j) maxxer = field_in(i,1,j) DO l = 2 , 12 IF ( field_in(i,l,j) .LT. minner ) THEN minner = field_in(i,l,j) END IF IF ( field_in(i,l,j) .GT. maxxer ) THEN maxxer = field_in(i,l,j) END IF END DO field_min(i,j) = minner field_max(i,j) = maxxer END DO END DO END SUBROUTINE monthly_min_max SUBROUTINE monthly_avg ( field_in , field_avg , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , DIMENSION(ims:ime,12,jms:jme) , INTENT(IN) :: field_in REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_avg INTEGER :: i , j DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) field_avg(i, j) = SUM(field_in(i, :, j)) / 12 END DO END DO END SUBROUTINE monthly_avg SUBROUTINE monthly_interp_to_date ( field_in , date_str , field_out , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte CHARACTER (LEN=24) , INTENT(IN) :: date_str REAL , DIMENSION(ims:ime,12,jms:jme) , INTENT(IN) :: field_in REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_out INTEGER :: i , j , l INTEGER , DIMENSION(0:13) :: middle INTEGER :: target_julyr , target_julday , target_date INTEGER :: julyr , julday , int_month , month1 , month2 REAL :: gmt CHARACTER (LEN=4) :: yr CHARACTER (LEN=2) :: mon , day15 WRITE(day15,FMT='(I2.2)') 15 DO l = 1 , 12 WRITE(mon,FMT='(I2.2)') l CALL get_julgmt ( date_str(1:4)//'-'//mon//'-'//day15//'_'//'00:00:00.0000' , julyr , julday , gmt ) middle(l) = julyr*1000 + julday END DO l = 0 middle(l) = middle( 1) - 31 l = 13 middle(l) = middle(12) + 31 CALL get_julgmt ( date_str , target_julyr , target_julday , gmt ) target_date = target_julyr * 1000 + target_julday find_month : DO l = 0 , 12 IF ( ( middle(l) .LT. target_date ) .AND. ( middle(l+1) .GE. target_date ) ) THEN DO j = jts , MIN ( jde-1 , jte ) DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE int_month = l IF ( ( int_month .EQ. 0 ) .OR. ( int_month .EQ. 12 ) ) THEN month1 = 12 month2 = 1 ELSE month1 = int_month month2 = month1 + 1 END IF field_out(i,j) = ( field_in(i,month2,j) * ( target_date - middle(l) ) + & field_in(i,month1,j) * ( middle(l+1) - target_date ) ) / & ( middle(l+1) - middle(l) ) END DO END DO EXIT find_month END IF END DO find_month END SUBROUTINE monthly_interp_to_date SUBROUTINE eightday_selector ( field_in , date_str , field_out , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte CHARACTER (LEN=24) , INTENT(IN) :: date_str REAL , DIMENSION(ims:ime,46,jms:jme) , INTENT(IN) :: field_in REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_out INTEGER :: i , j INTEGER :: julyr, julday, eightday REAL :: gmt CALL get_julgmt ( date_str , julyr , julday , gmt ) eightday = ((julday-1) / 8) + 1 DO j = jts , MIN ( jde-1 , jte ) DO i = its , MIN (ide-1 , ite ) field_out(i,j) = field_in(i,eightday,j) END DO END DO END SUBROUTINE eightday_selector SUBROUTINE sfcprs (t, q, height, pslv, ter, avgsfct, p, & psfc, ez_method, & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE REAL, PARAMETER :: gamma = 6.5E-3 REAL, PARAMETER :: pconst = 10000.0 REAL, PARAMETER :: Rd = r_d REAL, PARAMETER :: TC = svpt0 + 17.5 REAL, PARAMETER :: gammarg = gamma * Rd / g REAL, PARAMETER :: rov2 = Rd / 2. INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte LOGICAL , INTENT ( IN ) :: ez_method REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: t, q, height, p REAL , DIMENSION (ims:ime, jms:jme) , INTENT(IN ):: pslv , ter, avgsfct REAL , DIMENSION (ims:ime, jms:jme) , INTENT(OUT):: psfc INTEGER :: i INTEGER :: j INTEGER :: k INTEGER , DIMENSION (its:ite,jts:jte) :: k500 , k700 , k850 LOGICAL :: l1 LOGICAL :: l2 LOGICAL :: l3 LOGICAL :: OK REAL :: gamma78 ( its:ite,jts:jte ) REAL :: gamma57 ( its:ite,jts:jte ) REAL :: ht ( its:ite,jts:jte ) REAL :: p1 ( its:ite,jts:jte ) REAL :: t1 ( its:ite,jts:jte ) REAL :: t500 ( its:ite,jts:jte ) REAL :: t700 ( its:ite,jts:jte ) REAL :: t850 ( its:ite,jts:jte ) REAL :: tfixed ( its:ite,jts:jte ) REAL :: tsfc ( its:ite,jts:jte ) REAL :: tslv ( its:ite,jts:jte ) IF ( ez_method ) THEN DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE psfc(i,j) = pslv(i,j) * ( 1.0 + gamma * ter(i,j) / avgsfct(i,j) ) ** ( - g / ( Rd * gamma ) ) END DO END DO ELSE k850 = 0 k700 = 0 k500 = 0 i = its j = jts DO k = kts+1 , kte IF (NINT(p(i,k,j)) .EQ. 85000) THEN k850(i,j) = k ELSE IF (NINT(p(i,k,j)) .EQ. 70000) THEN k700(i,j) = k ELSE IF (NINT(p(i,k,j)) .EQ. 50000) THEN k500(i,j) = k END IF END DO IF ( ( k850(i,j) .EQ. 0 ) .OR. ( k700(i,j) .EQ. 0 ) .OR. ( k500(i,j) .EQ. 0 ) ) THEN DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE psfc(i,j) = pslv(i,j) * ( 1.0 + gamma * ter(i,j) / t(i,1,j) ) ** ( - g / ( Rd * gamma ) ) END DO END DO RETURN ELSE DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE k850(i,j) = k850(its,jts) k700(i,j) = k700(its,jts) k500(i,j) = k500(its,jts) END DO END DO END IF DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE ht(i,j) = height(i,k850(i,j),j) END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE ht(i,j) = -ter(i,j) / ht(i,j) END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE psfc(i,j) = pslv(i,j) * (pslv(i,j) / p(i,k850(i,j),j)) ** ht(i,j) END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ( psfc(i,j) - 95000. ) .GE. 0. ) THEN p1(i,j) = 85000. ELSE IF ( ( psfc(i,j) - 70000. ) .GE. 0. ) THEN p1(i,j) = psfc(i,j) - pconst ELSE p1(i,j) = 50000. END IF END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE t850(i,j) = t(i,k850(i,j),j) * (1. + 0.608 * q(i,k850(i,j),j)) t700(i,j) = t(i,k700(i,j),j) * (1. + 0.608 * q(i,k700(i,j),j)) t500(i,j) = t(i,k500(i,j),j) * (1. + 0.608 * q(i,k500(i,j),j)) END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE gamma78(i,j) = ALOG(t850(i,j) / t700(i,j)) / ALOG (p(i,k850(i,j),j) / p(i,k700(i,j),j) ) gamma57(i,j) = ALOG(t700(i,j) / t500(i,j)) / ALOG (p(i,k700(i,j),j) / p(i,k500(i,j),j) ) END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ( psfc(i,j) - 95000. ) .GE. 0. ) THEN t1(i,j) = t850(i,j) ELSE IF ( ( psfc(i,j) - 85000. ) .GE. 0. ) THEN t1(i,j) = t700(i,j) * (p1(i,j) / (p(i,k700(i,j),j))) ** gamma78(i,j) ELSE IF ( ( psfc(i,j) - 70000. ) .GE. 0.) THEN t1(i,j) = t500(i,j) * (p1(i,j) / (p(i,k500(i,j),j))) ** gamma57(i,j) ELSE t1(i,j) = t500(i,j) ENDIF END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE tslv(i,j) = t1(i,j) * (pslv(i,j) / p1(i,j)) ** gammarg END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE tsfc(i,j) = tslv(i,j) - gamma * ter(i,j) END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE tfixed(i,j) = tc - 0.005 * (tsfc(i,j) - tc) ** 2 END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE l1 = tslv(i,j) .LT. tc l2 = tsfc(i,j) .LE. tc l3 = .NOT. l1 IF ( l2 .AND. l3 ) THEN tslv(i,j) = tc ELSE IF ( ( .NOT. l2 ) .AND. l3 ) THEN tslv(i,j) = tfixed(i,j) END IF END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE p1(i,j) = - ter(i,j) * g / ( rov2 * ( tsfc(i,j) + tslv(i,j) ) ) psfc(i,j) = pslv(i,j) * EXP ( p1(i,j) ) END DO END DO END IF END SUBROUTINE sfcprs SUBROUTINE sfcprs2(t, q, height, psfc_in, ter, avgsfct, p, & psfc, ez_method, & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE REAL, PARAMETER :: Rd = r_d INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte LOGICAL , INTENT ( IN ) :: ez_method REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: t, q, height, p REAL , DIMENSION (ims:ime, jms:jme) , INTENT(IN ):: psfc_in , ter, avgsfct REAL , DIMENSION (ims:ime, jms:jme) , INTENT(OUT):: psfc INTEGER :: i INTEGER :: j INTEGER :: k REAL :: tv_sfc_avg , tv_sfc , del_z IF ( ez_method ) THEN DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE tv_sfc_avg = avgsfct(i,j) * (1. + 0.608 * q(i,1,j)) del_z = height(i,1,j) - ter(i,j) psfc(i,j) = psfc_in(i,j) * EXP ( g * del_z / ( Rd * tv_sfc_avg ) ) END DO END DO ELSE DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE tv_sfc = t(i,1,j) * (1. + 0.608 * q(i,1,j)) del_z = height(i,1,j) - ter(i,j) psfc(i,j) = psfc_in(i,j) * EXP ( g * del_z / ( Rd * tv_sfc ) ) END DO END DO END IF END SUBROUTINE sfcprs2 SUBROUTINE sfcprs3( height , p , ter , slp , psfc , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , DIMENSION (ims:ime,kms:kme,jms:jme) , INTENT(IN ):: height, p REAL , DIMENSION (ims:ime, jms:jme) , INTENT(IN ):: ter , slp REAL , DIMENSION (ims:ime, jms:jme) , INTENT(OUT):: psfc INTEGER :: i INTEGER :: j INTEGER :: k LOGICAL :: found_loc REAL :: zl , zu , pl , pu , zm DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE IF ( ter(i,j) .LT. 50 ) THEN 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) CYCLE END IF found_loc = .FALSE. found_k_loc : DO k = kts+1 , kte-2 IF ( ( height(i,k ,j) .LE. ter(i,j) ) .AND. & ( height(i,k+1,j) .GT. ter(i,j) ) ) THEN zl = height(i,k ,j) zu = height(i,k+1,j) zm = ter(i,j) pl = p(i,k ,j) pu = p(i,k+1,j) psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) ) found_loc = .TRUE. EXIT found_k_loc END IF END DO found_k_loc IF ( .NOT. found_loc ) THEN IF ( slp(i,j) .GE. p(i,2,j) ) THEN zl = 0. zu = height(i,3,j) zm = ter(i,j) pl = slp(i,j) pu = p(i,3,j) psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) ) found_loc = .TRUE. ELSE found_slp_loc : DO k = kts+1 , kte-3 IF ( ( slp(i,j) .GE. p(i,k+1,j) ) .AND. & ( slp(i,j) .LT. p(i,k ,j) ) ) THEN zl = 0. zu = height(i,k+1,j) zm = ter(i,j) pl = slp(i,j) pu = p(i,k+1,j) psfc(i,j) = EXP ( ( LOG(pl) * ( zm - zu ) + LOG(pu) * ( zl - zm ) ) / ( zl - zu ) ) found_loc = .TRUE. EXIT found_slp_loc END IF END DO found_slp_loc END IF END IF IF ( .NOT. found_loc ) THEN print *,'i,j = ',i,j print *,'p column = ',p(i,2:,j) print *,'z column = ',height(i,2:,j) print *,'model topo = ',ter(i,j) CALL wrf_error_fatal3("",8341,& ' probs with sfc p computation ' ) END IF END DO END DO END SUBROUTINE sfcprs3 SUBROUTINE filter_topo ( ht_in , xlat , msftx , & fft_filter_lat , mf_fft , & pos_def , swap_pole_with_next_j , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , INTENT(IN) :: fft_filter_lat , mf_fft REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: ht_in REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx LOGICAL :: pos_def , swap_pole_with_next_j INTEGER :: i , j , j_lat_pos , j_lat_neg , k INTEGER :: i_kicker , ik , i1, i2, i3, i4 INTEGER :: i_left , i_right , ii REAL :: length_scale , sum REAL , DIMENSION(its:ite,jts:jte) :: ht_out CHARACTER (LEN=256) :: message IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN CALL wrf_error_fatal3("",8384,& 'filtering assumes all values on X' ) END IF j_lat_neg = 0 j_lat_pos = jde + 1 loop_neg : DO j = MIN(jde-1,jte) , jts , -1 IF ( xlat(its,j) .LT. 0.0 ) THEN IF ( ABS(xlat(its,j)) .GE. fft_filter_lat ) THEN j_lat_neg = j EXIT loop_neg END IF END IF END DO loop_neg loop_pos : DO j = jts , MIN(jde-1,jte) IF ( xlat(its,j) .GT. 0.0 ) THEN IF ( xlat(its,j) .GE. fft_filter_lat ) THEN j_lat_pos = j EXIT loop_pos END IF END IF END DO loop_pos DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) ht_out(i,j) = ht_in(i,j) END DO END DO DO j = MIN(j_lat_neg,jte) , jts , -1 i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 ) WRITE (message,*) 'SOUTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j) CALL wrf_debug(10,TRIM(message)) DO i = its , MIN(ide-1,ite) sum = 0. DO ik = 1 , i_kicker ii = i-ik IF ( ii .GE. ids ) THEN i_left = ii ELSE i_left = ( ii - ids ) + (ide-1)+1 END IF ii = i+ik IF ( ii .LE. ide-1 ) THEN i_right = ii ELSE i_right = ( ii - (ide-1) ) + its-1 END IF sum = sum + ht_in(i_left,j) + ht_in(i_right,j) END DO ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) END DO END DO DO j = MAX(j_lat_pos,jts) , MIN(jde-1,jte) i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 ) WRITE (message,*) 'NORTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j) CALL wrf_debug(10,TRIM(message)) DO i = its , MIN(ide-1,ite) sum = 0. DO ik = 1 , i_kicker ii = i-ik IF ( ii .GE. ids ) THEN i_left = ii ELSE i_left = ( ii - ids ) + (ide-1)+1 END IF ii = i+ik IF ( ii .LE. ide-1 ) THEN i_right = ii ELSE i_right = ( ii - (ide-1) ) + its-1 END IF sum = sum + ht_in(i_left,j) + ht_in(i_right,j) END DO ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) ht_in(i,j) = ht_out(i,j) END DO END DO END SUBROUTINE filter_topo SUBROUTINE filter_topo_old ( ht_in , xlat , msftx , fft_filter_lat , & dummy , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , INTENT(IN) :: fft_filter_lat , dummy REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: ht_in REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx INTEGER :: i , j , j_lat_pos , j_lat_neg INTEGER :: i_kicker , ik , i1, i2, i3, i4 REAL :: length_scale , sum REAL , DIMENSION(its:ite,jts:jte) :: ht_out IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN CALL wrf_error_fatal3("",8519,& 'filtering assumes all values on X' ) END IF j_lat_neg = 0 j_lat_pos = jde + 1 loop_neg : DO j = jts , MIN(jde-1,jte) IF ( xlat(its,j) .LT. 0.0 ) THEN IF ( ABS(xlat(its,j)) .LT. fft_filter_lat ) THEN j_lat_neg = j - 1 EXIT loop_neg END IF END IF END DO loop_neg loop_pos : DO j = jts , MIN(jde-1,jte) IF ( xlat(its,j) .GT. 0.0 ) THEN IF ( xlat(its,j) .GE. fft_filter_lat ) THEN j_lat_pos = j EXIT loop_pos END IF END IF END DO loop_pos DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) ht_out(i,j) = ht_in(i,j) END DO END DO DO j = j_lat_neg , jts , -1 i_kicker = MIN( MAX ( NINT(msftx(its,j)) , 1 ) , (ide - ids) / 2 ) print *,'j = ' , j, ', kicker = ',i_kicker DO i = its , MIN(ide-1,ite) IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN sum = 0.0 DO ik = 1 , i_kicker sum = sum + ht_in(i+ik,j) + ht_in(i-ik,j) END DO ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) ELSE IF ( ( i - i_kicker .LT. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN sum = 0.0 DO ik = 1 , i_kicker sum = sum + ht_in(i+ik,j) END DO i1 = i - i_kicker + ide -1 i2 = ide-1 i3 = ids i4 = i-1 DO ik = i1 , i2 sum = sum + ht_in(ik,j) END DO DO ik = i3 , i4 sum = sum + ht_in(ik,j) END DO ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) ELSE IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .GT. ide-1 ) ) THEN sum = 0.0 DO ik = 1 , i_kicker sum = sum + ht_in(i-ik,j) END DO i1 = i+1 i2 = ide-1 i3 = ids i4 = ids + ( i_kicker+i ) - ide DO ik = i1 , i2 sum = sum + ht_in(ik,j) END DO DO ik = i3 , i4 sum = sum + ht_in(ik,j) END DO ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) END IF END DO END DO DO j = j_lat_pos , MIN(jde-1,jte) i_kicker = MIN( MAX ( NINT(msftx(its,j)) , 1 ) , (ide - ids) / 2 ) print *,'j = ' , j, ', kicker = ',i_kicker DO i = its , MIN(ide-1,ite) IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN sum = 0.0 DO ik = 1 , i_kicker sum = sum + ht_in(i+ik,j) + ht_in(i-ik,j) END DO ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) ELSE IF ( ( i - i_kicker .LT. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN sum = 0.0 DO ik = 1 , i_kicker sum = sum + ht_in(i+ik,j) END DO i1 = i - i_kicker + ide -1 i2 = ide-1 i3 = ids i4 = i-1 DO ik = i1 , i2 sum = sum + ht_in(ik,j) END DO DO ik = i3 , i4 sum = sum + ht_in(ik,j) END DO ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) ELSE IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .GT. ide-1 ) ) THEN sum = 0.0 DO ik = 1 , i_kicker sum = sum + ht_in(i-ik,j) END DO i1 = i+1 i2 = ide-1 i3 = ids i4 = ids + ( i_kicker+i ) - ide DO ik = i1 , i2 sum = sum + ht_in(ik,j) END DO DO ik = i3 , i4 sum = sum + ht_in(ik,j) END DO ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) END IF END DO END DO DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) ht_in(i,j) = ht_out(i,j) END DO END DO END SUBROUTINE filter_topo_old subroutine dry_stratos ( theta, qv, phb, & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: theta, phb REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: qv INTEGER :: i, j, k, kk, istart, iend, jstart, jend, kstart, kend REAL :: ht1, ht2, theta1, theta2, htz, sat85, p_std_atmos CHARACTER*256:: str_debug DATA sat85 /0.0235755574/ do i = 1, 256 str_debug(i:i) = char(0) enddo istart = its iend = MIN(ide-1,ite) jstart = jts jend = MIN(jde-1,jte) kstart = kts kend = kte-1 DO j = jstart, jend DO i = istart, iend DO k = kend-3, kstart, -1 ht1 = phb(i,k,j)/9.8 ht2 = phb(i,k+2,j)/9.8 theta1 = theta(i,k,j) theta2 = theta(i,k+2,j) if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. (ht1.gt.4000.) ) then DO kk = k+3, kend htz = phb(i,kk,j)/9.8 p_std_atmos = exp(log(1.0-htz/44307.692)/0.19)*101325.0 qv(i,kk,j) = 0.622*sat85/(p_std_atmos-sat85) END DO goto 79 end if END DO 79 continue END DO END DO END SUBROUTINE dry_stratos real function snowHires (snow_in, latitude, elev, date_str, i,j) IMPLICIT NONE REAL, INTENT(IN):: latitude, elev, snow_in INTEGER, INTENT(IN):: i, j CHARACTER (LEN=24), INTENT(IN) :: date_str REAL :: snow_startz, del_lat, season_factor, snow_out REAL :: gmt INTEGER :: day_peak, day_of_year, julyr CHARACTER (LEN=256) :: dbg_msg CALL get_julgmt ( date_str , julyr , day_of_year , gmt ) if (latitude .gt. 0.0) then del_lat = (65.-latitude)/(65.-35.) day_peak = 80 else del_lat = (-65.-latitude)/(-65.+35.) day_peak = 264 endif snow_startz = (3900.-250.)*del_lat + 250. snow_startz = max(250., min(3900., snow_startz)) season_factor = 1. snow_out = 0. IF (elev .GT. snow_startz) THEN season_factor = ABS(COS((day_of_year - day_peak)*0.5*0.0174533)) snow_out = 0.999*(elev-snow_startz)/(4000.-snow_startz) write(dbg_msg,*) 'DEBUG_GT_SNOW ', day_of_year, latitude, elev, snow_in, snow_startz, season_factor, snow_out,i, j CALL wrf_debug (150, dbg_msg) ENDIF snowHires = MAX(snow_in, season_factor * snow_out) END FUNCTION snowHires real function make_IceNumber (Q_ice, temp) IMPLICIT NONE REAL, PARAMETER:: Ice_density = 890.0 REAL, PARAMETER:: PI = 3.1415926536 integer idx_rei real corr, reice, deice, Q_ice, temp double precision lambda real retab(95) data retab / & 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/ idx_rei = int(temp-179.) idx_rei = min(max(idx_rei,1),94) corr = temp - int(temp) reice = retab(idx_rei)*(1.-corr) + retab(idx_rei+1)*corr deice = 2.*reice * 1.E-6 lambda = 3.0 / deice make_IceNumber = Q_ice * lambda*lambda*lambda / (PI*Ice_density) return end function make_IceNumber real function make_DropletNumber (Q_cloud, qnwfa, xland) IMPLICIT NONE real:: Q_cloud, qnwfa, xland real, parameter:: PI = 3.1415926536 real, parameter:: am_r = PI*1000./6. real, dimension(15), parameter:: g_ratio = (/24,60,120,210,336, & & 504,720,990,1320,1716,2184,2730,3360,4080,4896/) double precision:: lambda, qnc real:: q_nwfa, x1, xDc integer:: nu_c if (qnwfa .le. 0.0) then if ((xland-1.5).gt.0.) then xDc = 17.E-6 nu_c = 12 else xDc = 11.E-6 nu_c = 4 endif else q_nwfa = MAX(99.E6, MIN(qnwfa,5.E10)) nu_c = MAX(2, MIN(NINT(2.5E10/q_nwfa), 15)) x1 = MAX(1., MIN(q_nwfa*1.E-9, 10.)) - 1. xDc = (30. - x1*20./9.) * 1.E-6 endif lambda = (4.0D0 + nu_c) / xDc qnc = Q_cloud / g_ratio(nu_c) * lambda*lambda*lambda / am_r make_DropletNumber = SNGL(qnc) return end function make_DropletNumber real function make_RainNumber (Q_rain, temp) IMPLICIT NONE real, intent(in):: Q_rain, temp double precision:: lambda, N0, qnr real, parameter:: PI = 3.1415926536 real, parameter:: am_r = PI*1000./6. N0 = 8.E6 if (temp .le. 271.15) then N0 = 8.E8 elseif (temp .gt. 271.15 .and. temp.lt.273.15) then N0 = 8. * 10**(279.15-temp) endif lambda = SQRT(SQRT(N0*am_r*6.0/Q_rain)) qnr = Q_rain / 6.0 * lambda*lambda*lambda / am_r make_RainNumber = SNGL(qnr) return end function make_RainNumber SUBROUTINE init_module_initialize END SUBROUTINE init_module_initialize END MODULE module_initialize_real