!REAL:MODEL_LAYER:INITIALIZATION #ifndef VERT_UNIT ! This MODULE holds the routines which are used to perform various initializations ! for the individual domains, specifically for the Eulerian, mass-based coordinate. !----------------------------------------------------------------------- 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 #ifdef DM_PARALLEL 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 #endif REAL , SAVE :: p_top_save INTEGER :: internal_time_loop CONTAINS !------------------------------------------------------------------- SUBROUTINE init_domain ( grid ) IMPLICIT NONE ! Input space and data. No gridded meteorological data has been stored, though. ! TYPE (domain), POINTER :: grid TYPE (domain) :: grid ! Local data. INTEGER :: idum1, idum2 CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) CALL init_domain_rk( grid & ! #include "actual_new_args.inc" ! ) END SUBROUTINE init_domain !------------------------------------------------------------------- SUBROUTINE init_domain_rk ( grid & ! #include "dummy_new_args.inc" ! ) USE module_optional_input IMPLICIT NONE ! Input space and data. No gridded meteorological data has been stored, though. ! TYPE (domain), POINTER :: grid TYPE (domain) :: grid #include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags ! Local domain indices and counters. 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 ! Local data 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 REAL , DIMENSION(max_eta) :: eta_levels INTEGER :: auto_levels_opt REAL :: max_dz, dzbot, dzstretch_s, dzstretch_u, z1, airmass REAL :: dclat ! INTEGER , PARAMETER :: nl_max = 1000 ! REAL , DIMENSION(nl_max) :: grid%dn 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 ! Excluded middle. LOGICAL :: any_valid_points INTEGER :: i_valid , j_valid ! Vert interpolation in WRF INTEGER :: k_max_p , k_min_p !-- Carsel and Parrish [1988] REAL , DIMENSION(100) :: lqmi REAL , DIMENSION(100) :: thickness , levels REAL :: t_start , t_end REAL , ALLOCATABLE , DIMENSION(:,:) :: clat_glob ! added for multiple specified sets of eta_levels with vertical grid nesting INTEGER :: ks, ke, id LOGICAL :: vnest !T if using vertical nesting with vet_refine_method=2, otherwise F INTEGER :: j_save INTEGER :: change_soil, change_soilw, iforce REAL:: temp_rho LOGICAL :: wif_upside_down = .FALSE. ! Test on consistency between namelist settings and the available data from geogrid. INTEGER :: geogrid_flag_error ! Vertical pressure checks REAL :: press_above, press_below ! Dimension information stored in grid data structure. 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 ) ! Check flags from geogrid and the various model settings for any inconsistency. ! The optional data from geogrid mostly started with the v4.0 release. Older ! WPS data could have the required fields. Assume users know what they are ! doing when they bring old data into the newer real program ... 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 ) .AND. & ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_erod .EQ. 0 ) ) THEN CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_erod = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF IF ( ( config_flags%mp_physics .EQ. thompsonaero ) .AND. & ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_clayfrac .EQ. 0 ) ) THEN CALL wrf_message ( '----- ERROR: mp=28 AND dust_emis= 1 AND flag_clayfrac = 0 ' ) geogrid_flag_error = geogrid_flag_error + 1 END IF IF ( ( config_flags%mp_physics .EQ. thompsonaero ) .AND. & ( config_flags%dust_emis .EQ. 1 ) .AND. ( flag_sandfrac .EQ. 0 ) ) THEN CALL wrf_message ( '----- ERROR: mp=28 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_fatal ('Either modify the namelist settings, or rebuild the geogrid/metgrid data' ) END IF ! Geogrid flags that are not yet used: FLAG_FRC_URB2D FLAG_LAI12M FLAG_URB_PARAM END IF ! Would the user prefer to forego the use of the level of max winds, or the ! tropopause level data? This is an option the user may select. While the ! additional data is able to provide good information (such as a better ! resolution of the jet, a better kink for the tropopause), there are ! horizontal gradients that are introduced. Near a boundary, these gradients ! would be permanent (due to their inclusion in the LBC file). To turn "off" ! the use of the max wind/trop data, set the flags for those levels to zero. 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 ! Lake Mask and depth assignment 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" ) ! Set lake depth over the ocean to be -3 m, and set the lake depth over land to be -2 m. 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 ! Send out a quick message about the time steps based on the map scale factors. 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 #if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) max_mf = wrf_dm_max_real ( max_mf ) #endif 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 ! Check to see if the boundary conditions are set properly in the namelist file. ! This checks for sufficiency and redundancy. CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) ! Some sort of "this is the first time" initialization. Who knows. grid%step_number = 0 grid%itimestep=0 ! Pull in the info in the namelist to compare it to the input data. grid%real_data_init_type = model_config_rec%real_data_init_type ! To define the base state, we call a USER MODIFIED routine to set the three ! necessary constants: p00 (sea level pressure, Pa), t00 (sea level temperature, K), ! and A (temperature difference, from 1000 mb to 300 mb, K). CALL const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat ) ! Save these constants to write out in model output file grid%t00 = t00 grid%p00 = p00 grid%tlp = a grid%tiso = tiso grid%p_strat = p_strat grid%tlp_strat = a_strat ! Are there any hold-ups to us bypassing the middle of the domain? These ! holdups would be situations where we need data in the middle of the domain. ! FOr example, if this si the first time period, we need the full domain ! processed for ICs. Also, if there is some sort of gridded FDDA turned on, or ! if the SST update is activated, then we can't just blow off the middle of the ! domain all willy-nilly. Other cases of these hold-ups? Sure - what if the ! user wants to smooth the CG topo, we need several rows and columns available. ! What if the lat/lon proj is used, then we need to run a spectral filter on ! the topo. Both are killers when trying to ignore data in the middle of the ! domain. ! If hold_ups = .F., then there are no hold-ups to excluding the middle ! domain processing. If hold_ups = .T., then there are hold-ups, and we ! must process the middle of the domain. hold_ups = ( internal_time_loop .EQ. 1 ) .OR. & ( config_flags%grid_fdda .NE. 0 ) .OR. & ( config_flags%sst_update .EQ. 1 ) .OR. & ( config_flags%all_ic_times ) .OR. & ( config_flags%polar ) ! There are a few checks that we need to do when the input data comes in with the middle ! excluded by WPS. IF ( flag_excluded_middle .NE. 0 ) THEN ! If this time period of data from WPS has the middle excluded, it had better be OK for ! us to have a hole. 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%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_fatal ( a_message ) END IF ! Make sure that the excluded middle data from metgrid is "wide enough". We only have to check ! when the excluded middle was actually used in WPS. 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_fatal ( a_message ) END IF END IF em_width = config_flags%spec_bdy_width ! We need to find if there are any valid non-excluded-middle points in this ! tile. If so, then we need to hang on to a valid i,j location. 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 ! Replace traditional seaice field with optional seaice (AFWA source) 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 ! Replace traditional seaice field with optional seaice percent (AFWA source) 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 ! Fix the snow (water equivalent depth, kg/m^2) and the snowh (physical snow ! depth, m) fields. 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) ! ( m -> kg/m^2 ) & ( reduce to liquid, 5:1 ratio ) 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) ! ( kg/m^2 -> m) & ( liquid to snow depth, 5:1 ratio ) 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 ! For backward compatibility, we might need to assign the map factors from ! what they were, to what they are. 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_fatal ( '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_fatal ( 'Older metgrid data cannot initialize a global domain' ) ENDIF ! Check to see what available surface temperatures we have. 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 ! we are OK ELSE CALL wrf_error_fatal ( 'We either need TSK or TAVGSFC, verify these fields are coming from WPS' ) END IF ! Since we require a skin temperature in the model, we can use the average 2-m temperature if provided. 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 ! Is there any vertical interpolation to do? The "old" data comes in on the correct ! vertical locations already. IF ( flag_metgrid .EQ. 1 ) THEN ! <----- START OF VERTICAL INTERPOLATION PART ----> num_metgrid_levels = grid%num_metgrid_levels IF ( config_flags%nest_interp_coord .EQ. 1 ) THEN ! At the location of maximum pressure in the column, get the temperature and height. These ! will be written out and could be used for vertical interpolation - to avoid extrapolation. ! Hey, we can also do minimum values, too. 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 this is data from the PINTERP program, it is emulating METGRID output. ! One of the caveats of this data is the way that the vertical structure is ! handled. We take the k=1 level and toss it (it is disposable), and we ! swap in the surface data. This is done for all of the 3d fields about ! which we show some interest: u, v, t, rh, ght, and p. For u, v, and rh, ! we assume no interesting vertical structure, and just assign the 1000 mb ! data. We directly use the 2-m temp for surface temp. We use the surface ! pressure field and the topography elevation for the lowest level of ! pressure and height, respectively. 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 ! Variables that are named differently between SI and WPS. 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 ! A user could request that the most coarse grid has the ! topography along the outer boundary smoothed. This smoothing ! is similar to the coarse/nest interface. The outer rows and ! cols come from the existing large scale topo, and then the ! next several rows/cols are a linear ramp of the large scale ! model and the hi-res topo from WPS. We only do this for the ! coarse grid since we are going to make the interface consistent ! in the model betwixt the CG and FG domains. 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 ! Filter the input topography if this is a global domain. IF ( ( config_flags%polar ) .AND. ( grid%fft_filter_lat .GT. 90 ) ) THEN CALL wrf_error_fatal ( '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 #if 1 dclat = 90./REAL(jde-jds) !(0.5 * 180/ny) 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 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) ! WARNING: this might present scaling issues on very large numbers of processors 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 ) #else find_j_index_of_fft_filter : DO j = jds , jde-1 IF ( ABS(grid%clat(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 grid%mf_fft = grid%msft(ids,j_save) #endif CALL pxft ( grid=grid & ,lineno=__LINE__ & ,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 ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) ! We stick the topo and map fac in an unused 3d array. The map scale ! factor and computational latitude are passed along for the ride ! (part of the transpose process - we only do 3d arrays) to determine ! "how many" values are used to compute the mean. We want a number ! that is consistent with the original grid resolution. DO j = jts, MIN(jte,jde-1) DO k = kts, kte DO i = its, MIN(ite,ide-1) grid%t_init(i,k,j) = 1. END DO END DO DO i = its, MIN(ite,ide-1) grid%t_init(i,1,j) = grid%ht(i,j) grid%t_init(i,2,j) = grid%msftx(i,j) grid%t_init(i,3,j) = grid%clat(i,j) END DO END DO # include "XPOSE_POLAR_FILTER_TOPO_z2x.inc" ! Retrieve the 2d arrays for topo, map factors, and the ! computational latitude. DO j = jpsx, MIN(jpex,jde-1) DO i = ipsx, MIN(ipex,ide-1) grid%ht_xxx(i,j) = grid%t_xxx(i,1,j) grid%mf_xxx(i,j) = grid%t_xxx(i,2,j) grid%clat_xxx(i,j) = grid%t_xxx(i,3,j) END DO END DO ! Get a mean topo field that is consistent with the grid ! distance on each computational latitude loop. CALL filter_topo ( grid%ht_xxx , grid%clat_xxx , grid%mf_xxx , & grid%fft_filter_lat , grid%mf_fft , & .FALSE. , .FALSE. , & ids, ide, jds, jde, 1 , 1 , & imsx, imex, jmsx, jmex, 1, 1, & ipsx, ipex, jpsx, jpex, 1, 1 ) ! Stick the filtered topo back into the dummy 3d array to ! transpose it back to "all z on a patch". DO j = jpsx, MIN(jpex,jde-1) DO i = ipsx, MIN(ipex,ide-1) grid%t_xxx(i,1,j) = grid%ht_xxx(i,j) END DO END DO # include "XPOSE_POLAR_FILTER_TOPO_x2z.inc" ! Get the un-transposed topo data. DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%ht(i,j) = grid%t_init(i,1,j) END DO END DO #else CALL filter_topo ( grid%ht , grid%clat , grid%msftx , & grid%fft_filter_lat , grid%mf_fft , & .FALSE. , .FALSE. , & ids, ide, jds, jde, 1,1, & ims, ime, jms, jme, 1,1, & its, ite, jts, jte, 1,1 ) #endif #endif 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_fatal ( a_message ) END IF ! If we have any input low-res surface pressure, we store it. 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 we have the low-resolution surface elevation, stick that in the ! "input" locations of the 3d height. We still have the "hi-res" topo ! stuck in the grid%ht array. The grid%landmask if test is required as some sources ! have ZERO elevation over water (thank you very much). IF ( flag_soilhgt .EQ. 1) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) ! IF ( grid%landmask(i,j) .GT. 0.5 ) THEN 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 IF END DO END DO END IF ! The number of vertical levels in the input data. There is no staggering for ! different variables. num_metgrid_levels = grid%num_metgrid_levels ! For AFWA UM data, swap incoming extra (theta-based) pressure with the standardly ! named (rho-based) pressure. 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 ! For UM data, the "surface" and the "first hybrid" level for the theta-level data fields are the same. ! Average the surface (k=1) and the second hybrid level (k=num_metgrid_levels-1) to get the first hybrid ! layer. We only do this for the theta-level data: pressure, temperature, specific humidity, and ! geopotential height (i.e. we do not modify u, v, or the rho-based pressure). 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 ! For UM data, the soil moisture comes in as kg / m^2. Divide by 1000 and layer thickness to get m^3 / m^3. 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 ! Check for and semi-fix missing surface fields. 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 ! Compute the mixing ratio from the input relative humidity. 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 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 ! Some data sets do not provide a 3d geopotential height field. 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 the pressure levels in the middle of the atmosphere are upside down, then ! this is hybrid data. Computing the new surface pressure should use sfcprs2. 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 ! Assign surface fields with original input values. If this is hybrid data, ! the values are not exactly representative. However - this is only for ! plotting purposes and such at the 0h of the forecast, so we are not all that ! worried. 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 ! The requested ptop for real data cases. p_top_requested = grid%p_top_requested ! Compute the top pressure, grid%p_top. For isobaric data, this is just the ! top level. For the generalized vertical coordinate data, we find the ! max pressure on the top level. We have to be careful of two things: ! 1) the value has to be communicated, 2) the value can not increase ! at subsequent times from the initial value. 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 ) #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) grid%p_top = wrf_dm_max_real ( grid%p_top ) #endif ! Compare the requested grid%p_top with the value available from the input data. 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_fatal ( 'p_top_requested < grid%p_top possible from data' ) END IF ! The grid%p_top valus is the max of what is available from the data and the ! requested value. We have already compared <, so grid%p_top is directly set to ! the value in the namelist. grid%p_top = p_top_requested ! For subsequent times, we have to remember what the grid%p_top for the first ! time was. Why? If we have a generalized vert coordinate, the grid%p_top value ! could fluctuate. 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 ) #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) grid%p_top = wrf_dm_max_real ( grid%p_top ) #endif 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_fatal ( 'grid%p_top > previous value' ) END IF grid%p_top = p_top_save ENDIF ! Get the monthly values interpolated to the current date for the traditional monthly ! fields of green-ness fraction and background albedo. 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 ) #if ( WRF_CHEM == 1 ) ! Chose the appropriate LAI veg mask for this date (used in the AFWA dust model) CALL eightday_selector ( grid%lai_veg_8day , current_date , grid%lai_vegmask , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) #endif ! Get the min/max of each i,j for the monthly green-ness fraction. 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 ) ! The model expects the green-ness and vegetation fraction values to be in percent, not fraction. 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. END DO END DO ! The model expects the albedo fields as a fraction, not a percent. Set the ! water values to 8%. 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 ! Added by G. Thompson 2013Sep10 ! Interpolate monthly aerosol climatology data to specific date/time. ! Since data are 3D, do over a loop of vertical levels using temporary array space. IF (config_flags%mp_physics.eq.THOMPSONAERO .and. P_QNWFA.gt.1 .and. config_flags%use_aero_icbc) then CALL wrf_debug ( 0 , 'Using Thompson_aerosol_aware so using QNWFA monthly climo arrays to create QNWFA_now') DO k = 1, num_metgrid_levels DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%qntemp(i, 1, j) = grid%QNWFA_jan(i,k,j) grid%qntemp(i, 2, j) = grid%QNWFA_feb(i,k,j) grid%qntemp(i, 3, j) = grid%QNWFA_mar(i,k,j) grid%qntemp(i, 4, j) = grid%QNWFA_apr(i,k,j) grid%qntemp(i, 5, j) = grid%QNWFA_may(i,k,j) grid%qntemp(i, 6, j) = grid%QNWFA_jun(i,k,j) grid%qntemp(i, 7, j) = grid%QNWFA_jul(i,k,j) grid%qntemp(i, 8, j) = grid%QNWFA_aug(i,k,j) grid%qntemp(i, 9, j) = grid%QNWFA_sep(i,k,j) grid%qntemp(i,10, j) = grid%QNWFA_oct(i,k,j) grid%qntemp(i,11, j) = grid%QNWFA_nov(i,k,j) grid%qntemp(i,12, j) = grid%QNWFA_dec(i,k,j) ENDDO ENDDO 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 ) DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%QNWFA_now(i,k,j) = grid%qntemp2(i,j) if(i.eq.its .and. j.eq.jts .and. k.eq.1) then write(a_message,*) ' DEBUG, ensuring QNWFA_now corner (its,1,jts) value: ', i,j,grid%QNWFA_now(i,k,j) CALL wrf_debug (1, a_message) endif ENDDO ENDDO ENDDO ENDIF IF (config_flags%mp_physics.eq.THOMPSONAERO .and. P_QNIFA.gt.1 .and. config_flags%use_aero_icbc) then DO k = 1, num_metgrid_levels DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%qntemp(i, 1, j) = grid%QNIFA_jan(i,k,j) grid%qntemp(i, 2, j) = grid%QNIFA_feb(i,k,j) grid%qntemp(i, 3, j) = grid%QNIFA_mar(i,k,j) grid%qntemp(i, 4, j) = grid%QNIFA_apr(i,k,j) grid%qntemp(i, 5, j) = grid%QNIFA_may(i,k,j) grid%qntemp(i, 6, j) = grid%QNIFA_jun(i,k,j) grid%qntemp(i, 7, j) = grid%QNIFA_jul(i,k,j) grid%qntemp(i, 8, j) = grid%QNIFA_aug(i,k,j) grid%qntemp(i, 9, j) = grid%QNIFA_sep(i,k,j) grid%qntemp(i,10, j) = grid%QNIFA_oct(i,k,j) grid%qntemp(i,11, j) = grid%QNIFA_nov(i,k,j) grid%qntemp(i,12, j) = grid%QNIFA_dec(i,k,j) ENDDO ENDDO 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 ) DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%QNIFA_now(i,k,j) = grid%qntemp2(i,j) ENDDO ENDDO ENDDO ENDIF ! Two ways to get the surface pressure. 1) If we have the low-res input surface ! pressure and the low-res topography, then we can do a simple hydrostatic ! relation. 2) Otherwise we compute the surface pressure from the sea-level ! pressure. ! Note that on output, grid%psfc is now hi-res. The low-res surface pressure and ! elevation are grid%psfc_gc and grid%ht_gc (same as grid%ght_gc(k=1)). 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_fatal ( 'not enough info for a p sfc computation' ) END IF ! If we have no input surface pressure, we'd better stick something in there. 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 ! Integrate the mixing ratio to get the vapor pressure. 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 this is UM data, the same moisture removed from the "theta" level pressure data can ! be removed from the "rho" level pressures. This is an approximation. We'll revisit to ! see if this is a bad idea. 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 ! Compute the difference between the dry, total surface pressure (input) and the ! dry top pressure (constant). 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 ) ! Compute the dry, hydrostatic surface pressure. 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 ) ! Compute the eta levels if not defined already. IF ( grid%znw(1) .NE. 1.0 ) THEN !DJW Check if any of the domains are going to use vertical !nesting with vert_refine_method=2. If so, set vnest as true. 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 !DJW If there are eta_levels defined in the namelist and at !least one domain is using vertical nesting, then we need to read in !the eta_levels. IF ((model_config_rec%eta_levels(1) .NE. -1.0) .AND. (vnest)) THEN !DJW Added code for specifying multiple domains' eta_levels. !First check to make sure that we've not specified more !eta_levels than the dimensionality of eta_levels can handle! This !issue will most likely cause a break sometime before this !check, however it doesn't hurt to include it. To increase max_eta, !go to frame/module_driver_constants.F. 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_fatal("too many vertical levels, increase max_eta in frame/module_driver_constants.F") ENDIF !Now set the eta_levels to what we specified in the namelist. We've !packed all the domains' eta_levels into a 'vector' and now we need !to pull only the section of the vector associated with our domain !of interest, which is between indicies ks and ke. 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) !Check the value of the first and last eta level for our domain, !then check that the vector of eta levels is only decreasing IF (eta_levels(1) .NE. 1.0) THEN CALL wrf_error_fatal("--- ERROR: the first specified eta_level is not 1.0") ENDIF IF (eta_levels(kde) .NE. 0.0) THEN CALL wrf_error_fatal("--- 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_fatal("--- ERROR: specified eta_levels are not uniformly decreasing from 1.0 to 0.0") ENDIF ENDDO !DJW End of added code for specifying eta_levels ELSE !We're not using vertical nesting with eta_levels defined for every domain !DJW Check if we're doing vertical nesting with integer refinement. 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 !DJW If we're doing vertical nesting using integer refinement and !we've got eta_levels specified in the namelist then make sure they are !for the parent domain and nothing else. 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_fatal( wrf_err_message ) !DJW Check the value of the first and last eta level for our !domain, then check that the vector of eta levels is only decreasing 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_fatal("--- ERROR: the first specified eta_level is not 1.0") ENDIF IF (eta_levels(kde) .NE. 0.0) THEN CALL wrf_error_fatal("--- 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_fatal("--- ERROR: specified eta_levels are not uniformly decreasing from 1.0 to 0.0") ENDIF ENDDO ELSE !DJW original code to set eta_levels 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 ! For vertical coordinate, compute 1d arrays. 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 ! The input field is temperature, we want potential temp. 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 ! On the eta surfaces, compute the dry pressure = mu eta, stored in ! grid%pb, since it is a pressure, and we don't need another kms:kme 3d ! array floating around. The grid%pb array is re-computed as the base pressure ! later after the vertical interpolations are complete. 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 ) ! All of the vertical interpolations are done in dry-pressure space. The ! input data has had the moisture removed (grid%pd_gc). The target levels (grid%pb) ! had the vapor pressure removed from the surface pressure, then they were ! scaled by the eta levels. 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 ! For the height field, the lowest level pressure is the slp (approximately "dry"). The ! lowest level of the input height field (to be associated with slp) then is an array ! of zeros. 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 #ifdef DM_PARALLEL ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte ! Stencil for pressure is required for the pressure difference for the max_wind ! and trop level data. # include "HALO_EM_VINTERP_UV_1.inc" #endif 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 ) ! Put things back to normal. 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 ! Now the rest of the variables on half-levels to inteprolate. 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 #ifdef DM_PARALLEL ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte ! Stencil for pressure is required for the pressure difference for the max_wind ! and trop level data. # include "HALO_EM_VINTERP_UV_1.inc" #endif ! Interpolate RH, diagnose Qv later when have temp and pressure. Temporarily ! store this in the u_1 space, for later diagnosis into Qv and stored into moist. 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 this is theta being interpolated, AND we have extra levels for temperature, ! convert those extra levels (trop and max wind) to potential temp. 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 ! Depending on the setting of interp_theta = T/F, t_gc is is either theta Xor ! temperature, and that means that the t_2 field is also the associated field. ! It is better to interpolate temperature and potential temperature in LOG(p), ! regardless of requested default. 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 ! It is better to interpolate pressure in p regardless of the default options 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 ! Do not have full pressure on eta levels, get a first guess at Qv by using ! dry pressure. The use of u_1 (rh) and v_1 (temperature) is temporary. ! We fix the approximation to Qv after the total pressure is available on ! eta surfaces. 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 ( 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 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 !..If we have number of water-friendly aerosols from monthly climo data, interpolate to WRF model levels. IF ( flag_qnwfa .EQ. 1 .and. (config_flags%use_aero_icbc.or.config_flags%use_rap_aero_icbc)) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNWFA ) THEN if(config_flags%use_rap_aero_icbc) then !HRRR - aerosol input from WPS CALL wrf_debug ( 0 , 'Using Thompson_aerosol_aware so vertically-interpolating QNWFA from WPS data to fill scalar') 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 , & 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 ) else CALL wrf_debug ( 0 , 'Using Thompson_aerosol_aware so vertically-interpolating QNWFA monthly climo arrays to fill scalar') CALL vert_interp ( grid%QNWFA_now , 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 , & 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 ) endif END IF END DO ELSEIF ( flag_qnwfa .EQ. 1 .and. (.NOT. config_flags%use_aero_icbc)) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNWFA ) THEN DO j = jts, MIN(jte,jde-1) DO k = kts, kte DO i = its, MIN(ite,ide-1) scalar(i,k,j,P_QNWFA) = 0. END DO END DO END DO END IF END DO END IF !..If we have number of ice-friendly aerosols from monthly climo data, interpolate to WRF model levels. IF ( flag_qnifa .EQ. 1 .and. (config_flags%use_aero_icbc.or.config_flags%use_rap_aero_icbc)) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNIFA ) THEN if(config_flags%use_rap_aero_icbc) then ! HRRR - aerosol input from WPS 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 , & 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 ) else CALL vert_interp ( grid%QNIFA_now , 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 , & 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 ) endif END IF END DO ELSEIF ( flag_qnifa .EQ. 1 .and. (.NOT. config_flags%use_aero_icbc)) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( 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,P_QNIFA) = 0. END DO END DO END DO END IF END DO END IF !========================================================================================= ! START OF OPTIONAL 3D DATA, USUALLY AEROSOLS !========================================================================================= #if ( WRF_CHEM == 1 ) ! Do we have the old data that came in on the same vertical levels as the other ! met variables? If so, we can skip all of this interpolation, as the pressure field ! is allocated, but all zeros. IF ( config_flags%gca_input_opt .EQ. 1 ) THEN IF ( ( config_flags%num_gca_levels .GT. 0 ) .AND. & ( ABS(grid %p_gca(its,config_flags%num_gca_levels/2,jts)) .GT. 1 ) ) THEN ! Insert source code here to vertically interpolate an extra set of 3d arrays ! that could be on a different vertical structure than the input atmospheric ! data. Mostly, this is expected to be for monthly data (such as background ! aerosol information). ! OPTIONAL DATA #1: GCA - Go Cart Aerosols: OH, H2O2, NO3 ! Pressure name: p_gca ! Number of vertical levels: num_gca_levels ! Variable names (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): oh, h2o2, no3 ! Option to interpolate data: gca_input_opt = 1 ! Not stored in scalar arrays. IF ( config_flags%gca_input_opt .EQ. 1 ) THEN CALL wrf_debug ( 0 , 'Using monthly GOcart Aerosol input: OH, H2O2, NO3 from metgrid input file' ) ! There are three fields - they are 3d, so no easy way to loop over them. ! OH - Hydroxyl ! H2O2 - Hydrogen Peroxide ! NO3 - Nitrate DO k = 1, config_flags%num_gca_levels WRITE(a_message,*) ' transferring each K-level ', k, ' to OH, sample Jan data, ', grid % oh_gca_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 % oh_gca_jan(i,k,j) grid%qntemp(i, 2, j) = grid % oh_gca_feb(i,k,j) grid%qntemp(i, 3, j) = grid % oh_gca_mar(i,k,j) grid%qntemp(i, 4, j) = grid % oh_gca_apr(i,k,j) grid%qntemp(i, 5, j) = grid % oh_gca_may(i,k,j) grid%qntemp(i, 6, j) = grid % oh_gca_jun(i,k,j) grid%qntemp(i, 7, j) = grid % oh_gca_jul(i,k,j) grid%qntemp(i, 8, j) = grid % oh_gca_aug(i,k,j) grid%qntemp(i, 9, j) = grid % oh_gca_sep(i,k,j) grid%qntemp(i,10, j) = grid % oh_gca_oct(i,k,j) grid%qntemp(i,11, j) = grid % oh_gca_nov(i,k,j) grid%qntemp(i,12, j) = grid % oh_gca_dec(i,k,j) END DO END DO IF ( k .EQ. 1 ) THEN WRITE(a_message,*) ' GOcart Aerosols OH (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,*) ' GOcart Aerosols OH (now) ', grid%qntemp2(its,jts) CALL wrf_debug ( 1 , a_message) END IF DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid % oh_gca_now(i,k,j) = grid%qntemp2(i,j) END DO END DO END DO CALL vert_interp ( grid % oh_gca_now , grid%p_gca , grid%backg_oh , 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_gca_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 ) DO k = 1, config_flags%num_gca_levels WRITE(a_message,*) ' transferring each K-level ', k, ' to H2O2, sample Jan data, ', grid %h2o2_gca_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 %h2o2_gca_jan(i,k,j) grid%qntemp(i, 2, j) = grid %h2o2_gca_feb(i,k,j) grid%qntemp(i, 3, j) = grid %h2o2_gca_mar(i,k,j) grid%qntemp(i, 4, j) = grid %h2o2_gca_apr(i,k,j) grid%qntemp(i, 5, j) = grid %h2o2_gca_may(i,k,j) grid%qntemp(i, 6, j) = grid %h2o2_gca_jun(i,k,j) grid%qntemp(i, 7, j) = grid %h2o2_gca_jul(i,k,j) grid%qntemp(i, 8, j) = grid %h2o2_gca_aug(i,k,j) grid%qntemp(i, 9, j) = grid %h2o2_gca_sep(i,k,j) grid%qntemp(i,10, j) = grid %h2o2_gca_oct(i,k,j) grid%qntemp(i,11, j) = grid %h2o2_gca_nov(i,k,j) grid%qntemp(i,12, j) = grid %h2o2_gca_dec(i,k,j) END DO END DO IF ( k .EQ. 1 ) THEN WRITE(a_message,*) ' GOcart Aerosols H2O2 (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,*) ' GOcart Aerosols H2O2 (now) ', grid%qntemp2(its,jts) CALL wrf_debug ( 1 , a_message) END IF DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid %h2o2_gca_now(i,k,j) = grid%qntemp2(i,j) END DO END DO END DO CALL vert_interp ( grid %h2o2_gca_now , grid%p_gca , grid%backg_h2o2 , 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_gca_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 ) DO k = 1, config_flags%num_gca_levels WRITE(a_message,*) ' transferring each K-level ', k, ' to NO3, sample Jan data, ', grid % no3_gca_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 % no3_gca_jan(i,k,j) grid%qntemp(i, 2, j) = grid % no3_gca_feb(i,k,j) grid%qntemp(i, 3, j) = grid % no3_gca_mar(i,k,j) grid%qntemp(i, 4, j) = grid % no3_gca_apr(i,k,j) grid%qntemp(i, 5, j) = grid % no3_gca_may(i,k,j) grid%qntemp(i, 6, j) = grid % no3_gca_jun(i,k,j) grid%qntemp(i, 7, j) = grid % no3_gca_jul(i,k,j) grid%qntemp(i, 8, j) = grid % no3_gca_aug(i,k,j) grid%qntemp(i, 9, j) = grid % no3_gca_sep(i,k,j) grid%qntemp(i,10, j) = grid % no3_gca_oct(i,k,j) grid%qntemp(i,11, j) = grid % no3_gca_nov(i,k,j) grid%qntemp(i,12, j) = grid % no3_gca_dec(i,k,j) END DO END DO IF ( k .EQ. 1 ) THEN WRITE(a_message,*) ' GOcart Aerosols NO3 (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,*) ' GOcart Aerosols NO3 (now) ', grid%qntemp2(its,jts) CALL wrf_debug ( 1 , a_message) END IF DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid % no3_gca_now(i,k,j) = grid%qntemp2(i,j) END DO END DO END DO CALL vert_interp ( grid % no3_gca_now , grid%p_gca , grid%backg_no3 , 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_gca_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 IF END IF #endif ! Do we have the old data that came in on the same vertical levels as the other ! met variables? If so, we can skip all of this interpolation, as the pressure field ! is allocated, but all zeros. IF ( config_flags%wif_input_opt .EQ. 1 ) THEN IF ( ( config_flags%num_wif_levels .GT. 0 ) .AND. & ( ABS(grid %p_wif_jan(its,config_flags%num_wif_levels/2,jts)) .GT. 1 ) ) THEN ! OPTIONAL DATA #2: Thompson Water-Friendly Ice-Friendly Aerosols ! Pressure name (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): p_wif ! Number of vertical levels: num_wif_levels ! Variable names (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): w_wif, i_wif ! Option to interpolate data: wif_input_opt = 1 ! Stored in scalar arrays, tested and assumed to be upside down. IF ( ( config_flags%wif_input_opt .EQ. 1 ) .AND. & ( config_flags%mp_physics .EQ. THOMPSONAERO ) .AND. & ( flag_qnwfa .EQ. 1 ) .AND. & ( flag_qnifa .EQ. 1 ) ) THEN CALL wrf_debug ( 0 , 'Using monthly Water-Friendly and Ice-Friendly aerosols from metgrid input file' ) ! There are two data fields plus pressure - they are 3d, so no easy way to loop over them. ! QNWFA - Number concentration water-friendly aerosols ! QNIFA - Number concentration ice-friendly aerosols ! First, get the pressure temporally interpolated to the correct date/time since ! this is a hybrid coordinate (not isobaric), and the pressure changes by month. ! NOTE: The input pressure is not vertically interpolated, but the other two input ! fields (QNWFA, QNIFA) are interpolated to the WRF eta coordinate. 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 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 !..Capture the monthly climatology value for the lowest level because we use later to compute surface flux value. DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%QNWFA_now(i,1,j) = grid%w_wif_now(i,1,j) END DO END DO 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 ) 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 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 IF ( ( config_flags%mp_physics .EQ. THOMPSONAERO ) .AND. & ( ( config_flags%wif_input_opt .EQ. USE_WIF_INPUT ) .OR. & ( config_flags%use_aero_icbc ) ) .AND. & ( ( flag_qnwfa .NE. 1 ) .OR. & ( flag_qnifa .NE. 1 ) ) ) THEN WRITE (a_message,*) "--- ERROR: QNWFA or QNIFA fields are not in the metgrid input, they can't be interpolated" CALL wrf_message ( a_message) WRITE (a_message,*) '--- ERROR: See https://www2.mmm.ucar.edu/wrf/users/wrfv3.9/mp28_updated.html' CALL wrf_message ( a_message) WRITE (a_message,*) '--- ERROR: Neither wif_input_opt=1 nor use_aero_icbc=T are allowed without aerosol data' CALL wrf_error_fatal ( a_message) END IF END IF END IF !========================================================================================= ! END OF OPTIONAL 3D DATA, USUALLY AEROSOLS !========================================================================================= ! If this is UM data, put the dry rho-based pressure back into the dry pressure array. ! Since the dry pressure is no longer needed, no biggy. 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 #ifdef DM_PARALLEL ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte ! For the U and V vertical interpolation, we need the pressure defined ! at both the locations for the horizontal momentum, which we get by ! averaging two pressure values (i and i-1 for U, j and j-1 for V). The ! pressure field on input (grid%pd_gc) and the pressure of the new coordinate ! (grid%pb) would only need an 8 point stencil. However, the i+1 i-1 and ! j+1 j-1 for the pressure difference for the max_wind and trop level data ! require an 8 stencil for all of the mass point variables and a 24-point ! stencil for U and V. # include "HALO_EM_VINTERP_UV_1.inc" #endif 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 ! <----- END OF VERTICAL INTERPOLATION PART ----> ! Set the temperature of the inland lakes to tavgsfc if the temperature is available ! and islake is > num_veg_cat 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 ! We don't have tavgsfc 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 ! Save the grid%tsk field for later use in the sea ice surface temperature ! for the Noah LSM scheme. 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 ! Protect against bad grid%tsk values over water by supplying grid%sst (if it is ! available, and if the grid%sst is reasonable). 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 ! Take the data from the input file and store it in the variables that ! use the WRF naming and ordering conventions. 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 ! Set flag integers for presence of snowh and soilw fields grid%ifndsnowh = flag_snowh IF (num_sw_levels_input .GE. 1) THEN grid%ifndsoilw = 1 ELSE grid%ifndsoilw = 0 END IF ! Set flag integers for presence of albsi, snowsi, and icedepth fields 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 ! Only certain land surface schemes are able to work with the NLCD data. 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_fatal ( '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 ! We require input data for the various LSM schemes. 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_fatal ( 'Not enough soil temperature data for Noah LSM scheme.') END IF CASE (RUCLSMSCHEME) IF ( num_st_levels_input .LT. 2 ) THEN CALL wrf_error_fatal ( 'Not enough soil temperature data for RUC LSM scheme.') END IF CASE (PXLSMSCHEME) IF ( num_st_levels_input .LT. 2 ) THEN CALL wrf_error_fatal ( '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_fatal ( 'Not enough soil temperature data for CLM LSM scheme.') END IF !---------- fds (06/2010) --------------------------------- CASE (SSIBSCHEME) IF ( num_st_levels_input .LT. 2 ) THEN CALL wrf_error_fatal ( 'Not enough soil temperature data for SSIB LSM scheme.') END IF IF ( eta_levels(2) .GT. 0.982 ) THEN CALL wrf_error_fatal ( '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 ! surface_input_source=1 => use data from static file (fractional category as input) ! surface_input_source=2 => use data from grib file (dominant category as input) ! surface_input_source=3 => use dominant data from static file (dominant category as input) IF ( any_valid_points ) THEN IF ( config_flags%surface_input_source .EQ. 1 ) THEN ! Generate the vegetation and soil category information from the fractional input ! data, or use the existing dominant category fields if they exist. 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) ) ! Make all the veg/soil parms the same so as not to confuse the developer. 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 ! Do we have dominant soil and veg data from the input already? 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 ! Do we have dominant soil and veg data from the static input already? 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_fatal ( 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_fatal ( a_message ) END IF ! Need to match isltyp to landmask 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) = 8 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 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) CALL wrf_debug(0,a_message) END IF END IF ! Split NUDAPT Urban Parameters 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)) 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 ) 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 ! Adjustments for the seaice field PRIOR to the grid%tslb computations. This is ! is for the 5-layer scheme. 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 ) ! Land use assignment. 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 grid%tmn and grid%tsk. fix_tsk_tmn : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) CASE ( SLABSCHEME , LSMSCHEME , NOAHMPSCHEME , RUCLSMSCHEME, PXLSMSCHEME,CLMSCHEME, 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 ! Is the grid%tsk reasonable? 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_fatal ( 'grid%tsk unreasonable' ) end if END IF END DO END DO END IF ! Is the grid%tmn reasonable? 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_fatal ( 'grid%tmn unreasonable' ) endif END IF END DO END DO ! Minimum soil values, residual, from RUC LSM scheme. For input from Noah or EC, and using ! RUC LSM scheme, this must be subtracted from the input total soil moisture. For ! input RUC data and using the Noah LSM scheme, this value must be added to the soil ! moisture input. 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 /) ! 0.004, 0.065, 0.020, 0.004, 0.008 /) ! has extra levels for playa, lava, and white sand ! If Unified Model soil moisture input, add lqmi since UM gives us available soil moisture, not total (AFWA source) 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 ! At the initial time we care about values of soil moisture and temperature, other times are ! ignored by the model, so we ignore them, too. 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 !+---+-----------------------------------------------------------------+ ! Some bad values of soil moisture are possible (huge negative and positive), but they ! appear to occur only along coastlines, so instead of overwriting with small moisture ! values, use relatively large moisture val. Orig code checked for large negative but ! not positive values, mods here reset either. G. Thompson (28 Feb 2008). ! grid%smois(i,:,j) = 0.499 ! ELSEIF ( (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) .gt. 1.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.499 !+---+-----------------------------------------------------------------+ 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 ) ! 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 *,'RUC -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) iicount = iicount + 1 grid%smois(i,:,j) = 0.005 !+---+-----------------------------------------------------------------+ ! Same comment as above. ! grid%smois(i,:,j) = 0.499 ! ELSEIF ( (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) .gt. 1.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.499 !+---+-----------------------------------------------------------------+ 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 !+---+-----------------------------------------------------------------+ ! Fudge soil moisture higher where canopy water is non-zero. ! G. Thompson (12 Jun 2008) ! 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%canwat(i,j) .GT. 1.01 .AND. grid%landmask(i,j) .GT. 0.5 ) THEN ! print *,' CANWAT: moisten soil a bit more at i,j =',i,j,grid%canwat(i,j) ! grid%smois(i,1,j) = grid%smois(i,1,j) + (grid%canwat(i,j)**0.33333)*0.04 ! grid%smois(i,1,j) = MIN(0.499, grid%smois(i,1,j)) ! grid%smois(i,2,j) = grid%smois(i,2,j) + (grid%canwat(i,j)**0.33333)*0.01 ! grid%smois(i,2,j) = MIN(0.499, grid%smois(i,2,j)) ! end if ! END DO ! END DO !+---+-----------------------------------------------------------------+ 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 ) ! grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) - lqmi(grid%isltyp(i,j)) , 0.005 ) END DO END DO ELSE IF ( flag_soil_levels == 1 ) THEN ! no op END IF CASE ( PXLSMSCHEME ) iicount = 0 IF ( flag_soil_layers == 1 ) THEN ! no op 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 ) ! grid%smois(i,:,j) = MAX ( grid%smois(i,:,j) + lqmi(grid%isltyp(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 ! Is the grid%tslb reasonable? 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. & !fds ( model_config_rec%sf_surface_physics(grid%id) .NE. CLMSCHEME ).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,SSIBSCHEME ) ! CALL wrf_error_fatal ( 'Assigned constant soil moisture to 0.3, stopping') 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_fatal ( '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_fatal ( '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_fatal ( '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_fatal ( 'grid%tslb unreasonable 4' ) endif END IF END DO END DO END IF ! Adjustments for the seaice field AFTER the grid%tslb computations. This is ! is for the Noah LSM scheme. 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 ) ! Let us make sure (again) that the grid%landmask and the veg/soil categories match. 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_fatal ( '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 ! fill grid%sst array with grid%tsk if missing in real input (needed for time-varying grid%sst in wrf) 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 !tgs set snoalb to land value if the water point is covered with ice 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 ! From the full level data, we can get the half levels, reciprocals, and layer ! thicknesses. These are all defined at half level locations, so one less level. ! We allow the vertical coordinate to *accidently* come in upside down. We want ! the first full level to be the ground surface. ! Check whether grid%znw (full level) data are truly full levels. If not, we need to adjust them ! to be full levels. ! in this test, we check if grid%znw(1) is neither 0 nor 1 (within a tolerance of 10**-5) 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...' ! We want to ignore the first value if it's negative 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 ! Let's check our changes 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_fatal("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 ! Now the same sort of computations with the half eta levels, even ANOTHER ! level less than the one above. 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 ! Scads of vertical coefficients. 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) ! Inverse grid distances. grid%rdx = 1./config_flags%dx grid%rdy = 1./config_flags%dy ! Some of the many weird geopotential initializations that we'll see today: grid%ph0 is total, ! and grid%ph_2 is a perturbation from the base state geopotential. We set the base geopotential ! at the lowest level to terrain elevation * gravity. 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 ! Base state potential temperature and inverse density (alpha = 1/rho) from ! the half eta levels and the base-profile surface pressure. Compute 1/rho ! from equation of state. The potential temperature is a perturbation from t0. 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 ! Base state pressure is a function of eta level and terrain, only, plus ! the hand full of constants: p00 (sea level pressure, Pa), t00 (sea level ! temperature, K), and A (temperature difference, from 1000 mb to 300 mb, K). 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 ! temporary, full lev base pressure 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 ! temp = t00 + A*LOG(grid%pb(i,k,j)/p00) 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 ! Base state mu is defined as base state surface pressure minus grid%p_top grid%MUB(i,j) = p_surf - grid%p_top ! Dry surface pressure is defined as the following (this mu is from the input file ! computed from the dry pressure). Here the dry pressure is just reconstituted. pd_surf = grid%MU0(i,j) + grid%p_top ! Integrate base geopotential, starting at terrain elevation. This assures that ! the base state is in exact hydrostatic balance with respect to the model equations. ! This field is on full levels. 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_fatal( 'initialize_real: hypsometric_opt should be 1 or 2' ) END IF END DO END DO !+---+-----------------------------------------------------------------+ ! New addition by Greg Thompson to dry out the stratosphere. ! CALL wrf_debug ( 0 , ' calling routine to dry stratosphere') ! CALL dry_stratos ( grid%t_2, moist(:,:,:,P_QV), grid%phb, & ! ids , ide , jds , jde , kds , kde , & ! ims , ime , jms , jme , kms , kme , & ! its , ite , jts , jte , kts , kte ) !+---+-----------------------------------------------------------------+ ! Fill in the outer rows and columns to allow us to be sloppy. 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 ! Compute the total column perturbation dry pressure (grid%mub + grid%mu_2 + ptop = dry grid%psfc). 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 ! Fill in the outer rows and columns to allow us to be sloppy. 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 ! Assign the potential temperature (perturbation from t0) and qv on all the mass ! point locations. 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 ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum ! equation) down from the top to get the pressure perturbation. First get the pressure ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. 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) ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two ! inverse density fields (total and perturbation). 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 1 ! This is the hydrostatic equation used in the model after the small timesteps. In ! the model, grid%al (inverse density) is computed from the geopotential. 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 ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure. ! Note that al*p approximates Rd*T and dLOG(p) does z. ! Here T varies mostly linear with z, the first-order integration produces better result. 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 #else ! Get the perturbation geopotential from the 3d height array from WPS. DO k = 2,kte grid%ph_2(i,k,j) = grid%ph0(i,k,j)*g - grid%phb(i,k,j) END DO #endif ! Recompute density, simlar to what the model does. 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) #if 0 if ( internal_time_loop .EQ. 1 ) THEN if (i.eq.its .and. j.eq.its)then if (k.eq.kts)then print *,' k old al new al alb new alt dz (m) pres up Pres mid Pres down c3 k c3 k+1 c4 k c4 k+1' print *,' =======================================================================================================================================================================================================================================' endif print *,' ',k,qvf,grid%al(i,k,j),grid%alb(i,k,j),grid%al(i,k,j)+grid%alb(i,k,j),(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)),pfu,phm,pfd,grid%c3f(k),grid%c3f(k+1),grid%c4f(k),grid%c4f(k+1) endif endif #endif ENDDO END IF ! Compute pressure similarly to how computed within model. 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 ! Adjust the column pressure so that the computed 500 mb height is close to the ! input value (of course, not when we are doing hybrid input). 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 ! We only do the adjustment of height if we have the input data on pressure ! surfaces, and folks have asked to do this option. 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 ! Get the pressures on the full eta levels (grid%php is defined above as ! the full-lev base pressure, an easy array to use for 3d space). 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 these pressure levels trap 500 mb, use them to interpolate ! to the 500 mb level of the computed height. 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) ) ! z500 = ( zl * ( (50000.) - (pu ) ) + & ! zu * ( (pl ) - (50000.) ) ) / & ! ( (pl) - (pu) ) ! Compute the difference of the 500 mb heights (computed minus input), and ! then the change in grid%mu_2. The grid%php is still full-levels, base pressure. 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 ! Now we have full pressure on eta levels, get final computation of Qv. ! The use of u_1 (rh) and v_1 (temperature) is temporary. 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 ( 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 ! Compute pressure similarly to how computed within model, with final Qv. ! Do a re-balance or not? 0 = NOPE IF ( ( config_flags%rebalance .EQ. 0 ) .OR. & ( ( config_flags%rebalance .EQ. 2 ) .AND. ( config_flags%vert_refine_method .NE. 2 ) ) ) 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 ! rebalance 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 ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum ! equation) down from the top to get the pressure perturbation. First get the pressure ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. 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) ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two ! inverse density fields (total and perturbation). 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 1 ! This is the hydrostatic equation used in the model after the small timesteps. In ! the model, grid%al (inverse density) is computed from the geopotential. 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 ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure. ! Note that al*p approximates Rd*T and dLOG(p) does z. ! Here T varies mostly linear with z, the first-order integration produces better result. 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 #else ! Get the perturbation geopotential from the 3d height array from WPS. DO k = 2,kte grid%ph_2(i,k,j) = grid%ph0(i,k,j)*g - grid%phb(i,k,j) END DO #endif ! Recompute density, simlar to what the model does. 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 ! Compute pressure similarly to how computed within model. 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 ! Adjust the column pressure so that the computed 500 mb height is close to the ! input value (of course, not when we are doing hybrid input). 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 ! We only do the adjustment of height if we have the input data on pressure ! surfaces, and folks have asked to do this option. 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 ! Get the pressures on the full eta levels (grid%php is defined above as ! the full-lev base pressure, an easy array to use for 3d space). 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 these pressure levels trap 500 mb, use them to interpolate ! to the 500 mb level of the computed height. 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) ) ! Compute the difference of the 500 mb heights (computed minus input), and ! then the change in grid%mu_2. The grid%php is still full-levels, base pressure. 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 ! rebalance ! If this is data from the SI, then we probably do not have the original ! surface data laying around. Note that these are all the lowest levels ! of the respective 3d arrays. For surface pressure, we assume that the ! vertical gradient of grid%p prime is zilch. This is not all that important. ! These are filled in so that the various plotting routines have something ! to play with at the initial time for the model. 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 ! If this data is from WPS, then we have previously assigned the surface ! data for u, v, and t. If we have an input qv, welp, we assigned that one, ! too. Now we pick up the left overs, and if RH came in - we assign the ! mixing ratio. 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 ! 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%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)=moist(i,1,j,P_QV) grid%q2(i,j)=grid%qv_gc(i,1,j) END DO END DO END IF END IF CALL cpu_time(t_end) ! Set flag to denote that we are saving original values of HT, MUB, and ! PHB for 2-way nesting and cycling. grid%save_topo_from_real=1 ! Template for initializing tracer arrays. ! Right now, a small plane in the middle of the domain at lowest model level is ! defined. 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. ! tracer(i, 1, j, P_tr17_5) = 1. ! tracer(i, 1, j, P_tr17_6) = 1. ! tracer(i, 1, j, P_tr17_7) = 1. ! tracer(i, 1, j, P_tr17_8) = 1. END IF END DO END DO END IF ! Template for initializing trajectories. The i, j, and k starting locations ! are specified. Right now, a small plane in the middle of the domain is ! selected. grid%traj_i = -9999 grid%traj_j = -9999 grid%traj_k = -9999 grid%traj_lat = -9999 grid%traj_long = -9999 IF (config_flags%num_traj .gt. 0 .and. config_flags%traj_opt .gt. 0) THEN icount = 1 DO j = (jde + jds)/2 - 2, (jde + jds)/2 + 2, 1 DO i = (ide + ids)/2 - 2, (ide + ids)/2 + 2, 1 IF ( its .LE. i .and. ite .GE. i .and. jts .LE. j .and. jte .GE. j ) THEN grid%traj_i (icount) = i grid%traj_j (icount) = j grid%traj_k (icount) = 10 grid%traj_lat (icount) = grid%xlat(i,j) grid%traj_long(icount) = grid%xlong(i,j) END IF #ifdef DM_PARALLEL grid%traj_i (icount) = wrf_dm_max_real ( grid%traj_i (icount) ) grid%traj_j (icount) = wrf_dm_max_real ( grid%traj_j (icount) ) grid%traj_k (icount) = wrf_dm_max_real ( grid%traj_k (icount) ) grid%traj_lat (icount) = wrf_dm_max_real ( grid%traj_lat (icount) ) grid%traj_long(icount) = wrf_dm_max_real ( grid%traj_long(icount) ) #endif icount = icount + 1 IF (icount .GT. config_flags%num_traj) THEN EXIT END IF END DO END DO END IF ! Simple initialization for 3d ocean. IF ( config_flags%sf_ocean_physics .EQ. PWP3DSCHEME ) THEN ! From a profile of user defined temps, depths, and salinity - we ! construct a 3d ocean. Because this is a 1d profile, domains that ! have varied ocean characteristics that deviate should significantly from ! the provided initial state will probably give poor results. 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 ! Apparently, the mixed layer is 5 m. grid%om_ml = 5 ! Keep lat, lon info for the ocean model. grid%om_lon = grid%xlong grid%om_lat = grid%xlat ! If we have access to a non-horizontally isotropic SST, let's ! use that as a better starting point for the ocean temp. Note that ! we assume if this is an ice point that implies this is a land point ! for WRF. If it is a land point, then we do not have any ocean underneath. 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 !+---+-----------------------------------------------------------------+ !..Scale the lowest level aerosol data into an emissions rate. This is !.. very far from ideal, but need higher emissions where larger amount !.. of (climo) existing and lesser emissions where there exists fewer to !.. begin as a first-order simplistic approach. Later, proper connection to !.. emission inventory would be better, but, for now, scale like this: !.. where: Nwfa=50 per cc, emit 0.875E4 aerosols per second per grid box unit !.. that was tested as ~(20kmx20kmx50m = 2.E10 m**-3) !+---+-----------------------------------------------------------------+ IF ( config_flags%use_aero_icbc .AND. ( flag_qnwfa .EQ. 1 ) .AND. & ( config_flags%mp_physics .EQ. THOMPSONAERO ) ) THEN 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 airmass = 1./grid%alt(i,1,j) * z1 * config_flags%dx*config_flags%dy ! kg grid%qnwfa2d(i,j) = grid%QNWFA_now(i,1,j) * 0.000196 * (airmass*2.E-10) if(i.eq.its .and. j.eq.jts) then write(a_message,*) 'aero_sfc_flux: ', i,j,z1,1./grid%alt(i,1,j),airmass,grid%QNWFA_now(i,1,j),grid%qnwfa2d(i,j) CALL wrf_debug (1, a_message) endif enddo enddo ENDIF !+---+-----------------------------------------------------------------+ !..Let us ensure that double-moment microphysics variables have numbers !.. where there is mass. Currently doing this for Thompson-MP only, but !.. can consider doing it for every MP scheme that has 2-moment variables. !.. This is important because pressure-level RAP/HRRR files have mass but !.. not number values for example (whereas native model level files have !.. both). !+---+-----------------------------------------------------------------+ IF ( config_flags%mp_physics .EQ. THOMPSON .OR. & config_flags%mp_physics .EQ. THOMPSONAERO ) THEN !..As it occurs up above, temporarily utilizing the v_1 variable, !.. to hold temperature, which it does when time_loop=0. 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) !..Produce a sensible cloud droplet number concentration 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 !..Produce a sensible cloud ice number concentration 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 !..Produce a sensible rain number concentration 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 !+---+-----------------------------------------------------------------+ ! Added by Greg Thompson. Pre-set snow depth by latitude, elevation, and day-of-year. ! CALL wrf_debug ( 0 , ' calling routine to add snow in high mountain peaks') ! 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) = snowHires (grid%snowh(i,j), grid%xlat(i,j), grid%ht(i,j), current_date, i,j) ! grid%snow(i,j) = grid%snowh(i,j) * 1000. / 5. ! END DO ! END DO ! CALL wrf_debug ( 0 , ' DONE routine to add snow in high mountain peaks') !+---+-----------------------------------------------------------------+ ! checking whether var_sso exists in the domain ! if so, we set got_var_sso flag to true. This is later used in external/RSL_LITE/module_dm.F ! to check for this, when the topo_wind option is used. 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 #if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) grid%got_var_sso = wrf_dm_lor_logical ( grid%got_var_sso ) #endif ! Save the dry perturbation potential temperature. 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 ! Turn dry potential temperature into moist potential temperature ! at the very end of this routine, just before the halo communications. ! This field will be in the model IC and and used to construct the ! BC file. 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 #ifdef DM_PARALLEL # include "HALO_EM_INIT_1.inc" # include "HALO_EM_INIT_2.inc" # include "HALO_EM_INIT_3.inc" # include "HALO_EM_INIT_4.inc" # include "HALO_EM_INIT_5.inc" IF ( config_flags%sf_ocean_physics .EQ. PWP3DSCHEME ) THEN # include "HALO_EM_INIT_6.inc" END IF #endif RETURN END SUBROUTINE init_domain_rk !--------------------------------------------------------------------- SUBROUTINE const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat ) USE module_configure IMPLICIT NONE ! For the real-data-cases only. 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 & ! #include "actual_new_args.inc" ! ) END SUBROUTINE rebalance_driver !--------------------------------------------------------------------- SUBROUTINE rebalance ( grid & ! #include "dummy_new_args.inc" ! ) IMPLICIT NONE TYPE (domain) :: grid #include "dummy_new_decl.inc" 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 ! Local domain indices and counters. 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 ; ! note that tile is entire patch its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch 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 ; ! note that tile is entire patch jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch 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 ; ! note that tile is entire patch kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch END SELECT ALLOCATE ( t_init_int(ims:ime,kms:kme,jms:jme) ) ! Fill config_flags the options for a particular domain CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) ! Some of the many weird geopotential initializations that we'll see today: grid%ph0 is total, ! and grid%ph_2 is a perturbation from the base state geopotential. We set the base geopotential ! at the lowest level to terrain elevation * gravity. 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 ! To define the base state, we call a USER MODIFIED routine to set the three ! necessary constants: p00 (sea level pressure, Pa), t00 (sea level temperature, K), ! and A (temperature difference, from 1000 mb to 300 mb, K), and constant stratosphere ! temp (tiso, K) either from input file or from namelist (for backward compatibiliy). IF ( config_flags%use_baseparam_fr_nml ) then ! get these from namelist CALL wrf_message('ndown: using namelist constants') CALL const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat ) ELSE ! get these constants from model data 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_fatal(TRIM(wrf_err_message)) ENDIF ENDIF hold_ups = .true. ! Base state potential temperature and inverse density (alpha = 1/rho) from ! the half eta levels and the base-profile surface pressure. Compute 1/rho ! from equation of state. The potential temperature is a perturbation from t0. DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) ! Base state pressure is a function of eta level and terrain, only, plus ! the hand full of constants: p00 (sea level pressure, Pa), t00 (sea level ! temperature, K), and A (temperature difference, from 1000 mb to 300 mb, K). ! The fine grid terrain is ht_fine, the interpolated is grid%ht. 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 ! temp = t00 + A*LOG(pb/p00) grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 ! grid%t_init(i,k,j) = (t00 + A*LOG(grid%pb(i,k,j)/p00))*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 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 ! t_init_int(i,k,j)= (t00 + A*LOG(pb_int /p00))*(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 ! Base state mu is defined as base state surface pressure minus grid%p_top grid%MUB(i,j) = p_surf - grid%p_top ! Dry surface pressure is defined as the following (this mu is from the input file ! computed from the dry pressure). Here the dry pressure is just reconstituted. pd_surf = ( grid%MUB(i,j) + grid%MU_2(i,j) ) + grid%p_top ! Integrate base geopotential, starting at terrain elevation. This assures that ! the base state is in exact hydrostatic balance with respect to the model equations. ! This field is on full levels. 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_fatal( 'initialize_real: hypsometric_opt should be 1 or 2' ) END IF END DO END DO ! Replace interpolated terrain with fine grid values. 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 ! Perturbation fields. DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) ! The potential temperature is THETAnest = THETAinterp + ( TBARnest - TBARinterp) 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 ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum ! equation) down from the top to get the pressure perturbation. First get the pressure ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. 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) ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two ! inverse density fields (total and perturbation). 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 ! This is the hydrostatic equation used in the model after the small timesteps. In ! the model, grid%al (inverse density) is computed from the geopotential. 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 ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure. ! Note that al*p approximates Rd*T and dLOG(p) does z. ! Here T varies mostly linear with z, the first-order integration produces better result. 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 ! update psfc in fine grid 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 #ifdef DM_PARALLEL # include "HALO_EM_INIT_1.inc" # include "HALO_EM_INIT_2.inc" # include "HALO_EM_INIT_3.inc" # include "HALO_EM_INIT_4.inc" # include "HALO_EM_INIT_5.inc" #endif END SUBROUTINE rebalance !--------------------------------------------------------------------- RECURSIVE SUBROUTINE find_my_parent ( grid_ptr_in , grid_ptr_out , id_i_am , id_wanted , found_the_id ) ! RAR - Modified to correct problem in which the parent of a child domain could ! not be found in the namelist. This condition typically occurs while using the ! "allow_grid" namelist option when an inactive domain comes before an active ! domain in the list, i.e., the domain number of the active domain is greater than ! that of an inactive domain at the same level. ! 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 ! RAR LOGICAL :: found_the_id found_the_id = .FALSE. grid_ptr_sibling => grid_ptr_in nest = 0 ! RAR 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 ! RAR ELSE IF ( grid_ptr_sibling%num_nests .GT. 0 ) THEN ELSE IF ( grid_ptr_sibling%num_nests .GT. 0 .AND. nest .LT. grid_ptr_sibling%num_nests ) THEN nest = nest + 1 ! RAR grid_ptr_sibling => grid_ptr_sibling%nests(nest)%ptr ! RAR 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 ! RAR 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 ! Local TYPE(domain) , POINTER :: grid_ptr_holder INTEGER :: kid ! Initializations found_the_id = .FALSE. grid_ptr_holder => grid_ptr_in ! Have we found the correct location? If so, we can just pop back up with ! the pointer to the right location (i.e. the parent), thank you very much. IF ( id_wanted .EQ. grid_ptr_in%grid_id ) THEN found_the_id = .TRUE. grid_ptr_out => grid_ptr_in ! We gotta keep looking. ELSE ! We drill down and process each nest from this domain. We don't have to ! worry about siblings, as we are running over all of the kids for this parent, ! so it amounts to the same set of domains being tested. 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 #endif !--------------------------------------------------------------------- #ifdef VERT_UNIT !This is a main program for a small unit test for the vertical interpolation. program vint implicit none integer , parameter :: ij = 3 integer , parameter :: keta = 30 integer , parameter :: kgen =20 integer :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte integer :: generic real , dimension(1:ij,kgen,1:ij) :: fo , po real , dimension(1:ij,1:keta,1:ij) :: fn_calc , fn_interp , pn real , dimension(1:ij,1:ij) :: not_required_2d_1, not_required_2d_2, & not_required_2d_3, not_required_2d_4, & not_required_2d_5, not_required_2d_6 integer, parameter :: interp_type = 1 ! 2 integer, parameter :: extrap_type = 2 ! 1 ! integer, parameter :: lagrange_order = 2 ! 1 integer :: lagrange_order logical, parameter :: lowest_lev_from_sfc = .FALSE. ! .TRUE. logical, parameter :: use_levels_below_ground = .TRUE. ! .FALSE. ! .TRUE. logical, parameter :: use_surface = .TRUE. ! .FALSE. ! .TRUE. real , parameter :: zap_close_levels = 500. ! 100. integer, parameter :: force_sfc_in_vinterp = 6 ! 0 ! 6 integer :: k ids = 1 ; ide = ij ; jds = 1 ; jde = ij ; kds = 1 ; kde = keta ims = 1 ; ime = ij ; jms = 1 ; jme = ij ; kms = 1 ; kme = keta its = 1 ; ite = ij ; jts = 1 ; jte = ij ; kts = 1 ; kte = keta generic = kgen print *,' ' print *,'------------------------------------' print *,'UNIT TEST FOR VERTICAL INTERPOLATION' print *,'------------------------------------' print *,' ' do lagrange_order = 1 , 9 , 8 print *,' ' print *,'------------------------------------' print *,'Lagrange Order = ',lagrange_order print *,'------------------------------------' print *,' ' call fillitup ( fo , po , fn_calc , pn , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte , & generic , lagrange_order ) print *,' ' print *,'Level Pressure Field' print *,' (Pa) (generic)' print *,'------------------------------------' print *,' ' do k = 1 , generic write (*,fmt='(i2,2x,f12.3,1x,g15.8)' ) & k,po(2,k,2),fo(2,k,2) end do print *,' ' call vert_interp ( fo , po , fn_interp , pn , & not_required_2d_1, not_required_2d_2, & not_required_2d_3, not_required_2d_4, & not_required_2d_5, not_required_2d_6, & 0 , 0, 5000., 5000., 30000., & generic , 'T' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) print *,'Multi-Order Interpolator' print *,'------------------------------------' print *,' ' print *,'Level Pressure Field Field Field' print *,' (Pa) Calc Interp Diff' print *,'------------------------------------' print *,' ' do k = kts , kte-1 write (*,fmt='(i2,2x,f12.3,1x,3(g15.7))' ) & k,pn(2,k,2),fn_calc(2,k,2),fn_interp(2,k,2),fn_calc(2,k,2)-fn_interp(2,k,2) end do end do end program vint subroutine wrf_error_fatal (string) character (len=*) :: string print *,string stop end subroutine wrf_error_fatal subroutine fillitup ( fo , po , fn , pn , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte , & generic , lagrange_order ) implicit none 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 , lagrange_order real , dimension(ims:ime,generic,jms:jme) , intent(out) :: fo , po real , dimension(ims:ime,kms:kme,jms:jme) , intent(out) :: fn , pn integer :: i , j , k real , parameter :: piov2 = 3.14159265358 / 2. k = 1 do j = jts , jte do i = its , ite po(i,k,j) = 102000. end do end do do k = 2 , generic do j = jts , jte do i = its , ite po(i,k,j) = ( 5000. * ( 1 - (k-1) ) + 100000. * ( (k-1) - (generic-1) ) ) / (1. - real(generic-1) ) end do end do end do if ( lagrange_order .eq. 1 ) then do k = 1 , generic do j = jts , jte do i = its , ite fo(i,k,j) = po(i,k,j) ! fo(i,k,j) = sin(po(i,k,j) * piov2 / 102000. ) end do end do end do else if ( lagrange_order .eq. 2 ) then do k = 1 , generic do j = jts , jte do i = its , ite fo(i,k,j) = (((po(i,k,j)-5000.)/102000.)*((102000.-po(i,k,j))/102000.))*102000. ! fo(i,k,j) = sin(po(i,k,j) * piov2 / 102000. ) end do end do end do end if !!!!!!!!!!!! do k = kts , kte do j = jts , jte do i = its , ite pn(i,k,j) = ( 5000. * ( 0 - (k-1) ) + 102000. * ( (k-1) - (kte-1) ) ) / (-1. * real(kte-1) ) end do end do end do do k = kts , kte-1 do j = jts , jte do i = its , ite pn(i,k,j) = ( pn(i,k,j) + pn(i,k+1,j) ) /2. end do end do end do if ( lagrange_order .eq. 1 ) then do k = kts , kte-1 do j = jts , jte do i = its , ite fn(i,k,j) = pn(i,k,j) ! fn(i,k,j) = sin(pn(i,k,j) * piov2 / 102000. ) end do end do end do else if ( lagrange_order .eq. 2 ) then do k = kts , kte-1 do j = jts , jte do i = its , ite fn(i,k,j) = (((pn(i,k,j)-5000.)/102000.)*((102000.-pn(i,k,j))/102000.))*102000. ! fn(i,k,j) = sin(pn(i,k,j) * piov2 / 102000. ) end do end do end do end if end subroutine fillitup function skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) logical :: skip_middle_points_t integer :: ids , ide , jds , jde , i , j , em_width logical :: hold_ups skip_middle_points_t = .false. end function skip_middle_points_t #endif !--------------------------------------------------------------------- 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 ) ! Vertically interpolate the new field. The original field on the original ! pressure levels is provided, and the new pressure surfaces to interpolate to. 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 ! Local vars 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 ! Excluded middle. LOGICAL :: any_valid_points INTEGER :: i_valid , j_valid LOGICAL :: flip_data_required #ifdef VERT_UNIT LOGICAL, EXTERNAL :: skip_middle_points_t INTEGER :: em_width LOGICAL :: hold_ups #endif INTEGER :: final_zap_check_count , count_close_by_at_ko ! Vertical interpolation of the extra levels from metgrid: max wind and tropopause LOGICAL :: ok_data INTEGER :: ii, jj zap_close_extra_levels = 500 ! Horiontal loop bounds for different variable types. 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 ! We need to find if there are any valid non-excluded-middle points in this ! tile. If so, then we need to hang on to a valid i,j location. 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 ! The lowest level is the surface. Levels 2 through "generic" are supposed to ! be "bottom-up". Flip if they are not. This is based on the input pressure ! array. 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 ! Skip all of the levels below ground in the original data based upon the surface pressure. ! The ko_above_sfc is the index in the pressure array that is above the surface. If there ! are no levels underground, this is index = 2. The remaining levels are eligible for use ! in the vertical interpolation. 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 ! Piece together columns of the original input data. Pass the vertical columns to ! the iterpolator. DO i = istart , iend IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE ! If the surface value is in the middle of the array, three steps: 1) do the ! values below the ground (this is just to catch the occasional value that is ! inconsistently below the surface based on input data), 2) do the surface level, then ! 3) add in the levels that are above the surface. For the levels next to the surface, ! we check to remove any levels that are "too close". When building the column of input ! pressures, we also attend to the request for forcing the surface analysis to be used ! in a few lower eta-levels. ! Fill in the column from up to the level just below the surface with the input ! presssure and the input field (orig or old, which ever). For an isobaric input ! file, this data is isobaric. ! How many levels have we skipped in the input column. 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 ! Make sure the pressure just below the surface is not "too close", this ! will cause havoc with the higher order interpolators. In case of a "too close" ! instance, we toss out the offending level (NOT the surface one) by simply ! decrementing the accumulating loop counter. IF ( ordered_porig(count-1) - porig(i,1,j) .LT. zap_close_levels ) THEN count = count -1 zap = 1 zap_below = 1 END IF ! Add in the surface values. ordered_porig(count) = porig(i,1,j) ordered_forig(count) = forig(i,1,j) count = count + 1 ! A usual way to do the vertical interpolation is to pay more attention to the ! surface data. Why? Well it has about 20x the density as the upper air, so we ! hope the analysis is better there. We more strongly use this data by artificially ! tossing out levels above the surface that are beneath a certain number of prescribed ! eta levels at this (i,j). The "zap" value is how many levels of input we are ! removing, which is used to tell the interpolator how many valid values are in ! the column. The "count" value is the increment to the index of levels, and is ! only used for assignments. IF ( force_sfc_in_vinterp .GT. 0 ) THEN ! Get the pressure at the eta level. We want to remove all input pressure levels ! between the level above the surface to the pressure at this eta surface. That ! forces the surface value to be used through the selected eta level. Keep track ! of two things: the level to use above the eta levels, and how many levels we are ! skipping. 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 ! No request for special interpolation, so we just assign the next level to use ! above the surface as, ta da, the first level above the surface. I know, wow. ELSE knext = ko_above_sfc(i) END IF ! One more time, make sure the pressure just above the surface is not "too close", this ! will cause havoc with the higher order interpolators. In case of a "too close" ! instance, we toss out the offending level above the surface (NOT the surface one) by simply ! incrementing the loop counter. Here, count-1 is the surface level and knext is either ! the next level up OR it is the level above the prescribed number of eta surfaces. 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 ! This is easy, the surface is the lowest level, just stick them in, in this order. OK, ! there are a couple of subtleties. We have to check for that special interpolation that ! skips some input levels so that the surface is used for the lowest few eta levels. Also, ! we must make sure that we still do not have levels that are "too close" together. ELSE ! Initialize no input levels have yet been removed from consideration. zap = 0 ! The surface is the lowest level, so it gets set right away to location 1. ordered_porig(1) = porig(i,1,j) ordered_forig(1) = forig(i,1,j) ! We start filling in the array at loc 2, as in just above the level we just stored. count = 2 ! Are we forcing the interpolator to skip valid input levels so that the ! surface data is used through more levels? Essentially as above. 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 ! Fill in the data above the surface. The "knext" index is either the one ! just above the surface OR it is the index associated with the level that ! is just above the pressure at this (i,j) of the top eta level that is to ! be directly impacted with the surface level in interpolation. 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 ! Now get the column of the "new" pressure data. So, this one is easy. DO kn = kstart , kend ordered_pnew(kn) = pnew(i,kn,j) END DO ! How many levels (count) are we shipping to the Lagrange interpolator. IF ( ( use_levels_below_ground ) .AND. ( use_surface ) ) THEN ! Use all levels, including the input surface, and including the pressure ! levels below ground. We know to stop when we have reached the top of ! the input pressure data. 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 ! Use all levels (excluding the input surface) and including the pressure ! levels below ground. We know to stop when we have reached the top of ! the input pressure data. 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 ! Use all levels above the input surface pressure. kcount = ko_above_sfc(i)-1-zap_below count = 0 DO ko = 1 , generic IF ( porig(i,ko,j) .EQ. ordered_porig(kcount) ) THEN ! write (6,fmt='(f11.3,f11.3,g11.5)') porig(i,ko,j),ordered_porig(kcount),ordered_forig(kcount) kcount = kcount + 1 count = count + 1 ELSE ! write (6,fmt='(f11.3 )') porig(i,ko,j) END IF END DO kinterp_start = ko_above_sfc(i)-1-zap_below kinterp_end = kinterp_start + count - 1 END IF ! If we have additional levels (for example, some arrays have a "level of max winds" ! or a "level of the tropopause"), we insert them here. 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 #if 0 ! One final check to make sure that the delta pressures are OK. final_zap_check_count = 0 DO ko = kinterp_start , kinterp_end-1 count_close_by_at_ko = 0 close_by_at_ko : DO ! First, is the pressure difference between two neighboring layers too small? IF ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .LT. zap_close_levels ) THEN ! Make sure we are vertically located where this difference is meaningful. For ! example, a 5 hPa zap_close_levels makes sense at 850 hPa. However, a 5 hPa ! critical thickness is sill when the top few isobaric levels are 1, 2, 3 hPa. IF ( ordered_porig(ko) .GT. zap_close_levels * 10 ) THEN ! Now we have a grid point that we should remove. We pull out the pressure ! and field values, then we drop the rest of the array to fill in the ! missing spot, we increment our counter of bad values found in this column, ! and then we reduce the count of the total number of values in the array. DO kn = ko+1 , kinterp_end ordered_porig(kn-1) = ordered_porig(kn) ordered_forig(kn-1) = ordered_forig(kn) END DO final_zap_check_count = final_zap_check_count + 1 END IF END IF ! Did we pull down another pressure difference into the ko and ko+1 slots that will ! cause troubles? Make sure we don't spend an infinite amount of time in this loop. IF ( ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .GE. zap_close_levels ) .OR. & ( ordered_porig(ko) .LE. zap_close_levels * 10 ) ) THEN EXIT close_by_at_ko ELSE IF ( count_close_by_at_ko .GT. 3 ) THEN final_zap_check_count = 99 EXIT close_by_at_ko ELSE count_close_by_at_ko = count_close_by_at_ko + 1 CYCLE close_by_at_ko END IF END DO close_by_at_ko END DO IF ( final_zap_check_count .GT. 2 ) THEN WRITE ( message , * ) 'We are removing too many values: ',final_zap_check_count,' for (i,j) = ',i,j CALL wrf_error_fatal ( TRIM(message) ) END IF kinterp_end = kinterp_end - final_zap_check_count #else 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 #endif ! The polynomials are either in pressure or LOG(pressure). 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 ! Save the computed data. DO kn = kstart , kend fnew(i,kn,j) = ordered_fnew(kn) END DO ! There may have been a request to have the surface data from the input field ! to be assigned as to the lowest eta level. This assumes thin layers (usually ! the isobaric original field has the surface from 2-m T and RH, and 10-m U and V). 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) ! We call a Lagrange polynomial interpolator. The parallel concerns are put off as this ! is initially set up for vertical use. The purpose is an input column of pressure (all_x), ! and the associated pressure level data (all_y). These are assumed to be sorted (ascending ! or descending, no matter). The locations to be interpolated to are the pressures in ! target_x, probably the new vertical coordinate values. The field that is output is the ! target_y, which is defined at the target_x location. Mostly we expect to be 2nd order ! overlapping polynomials, with only a single 2nd order method near the top and bottom. ! When n=1, this is linear; when n=2, this is a second order interpolator. 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 ! cubic spline defs INTEGER :: K REAL :: DX, ALPHA, BETA, GAMMA, ETA REAL , DIMENSION(all_dim) :: P2 ! cubic spline defs ! Brought in for debug purposes, all of the computations are in a single column. INTEGER , INTENT(IN) :: i,j ! Local vars 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 ! Local vars for the problem of extrapolating theta below ground. 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 #ifdef VERT_UNIT REAL , PARAMETER :: RovCp = 0.287 #else REAL , PARAMETER :: RovCp = rcp #endif REAL , PARAMETER :: CRC_const1 = 11880.516 ! m REAL , PARAMETER :: CRC_const2 = 0.1902632 ! REAL , PARAMETER :: CRC_const3 = 0.0065 ! K/km 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_fatal ( 'This vertical interpolation failure is more typically associated with untested data sources to ungrib' ) END IF IF ( n .LT. 1 ) THEN CALL wrf_error_fatal ( 'pal, linear is about as low as we go' ) END IF ! We can pinch in the area of the higher order interpolation with vbound. If ! vbound = 0, no pinching. If vbound = m, then we make the lower "m" and upper ! "m" eta levels use a linear interpolation. vboundb = 4 vboundt = 0 ! Loop over the list of target x and y values. DO target_loop = 1 , target_dim ! Find the two trapping x values, and keep the indices. 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 ! Get full pressure back so that our extrpolations make sense. 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 ! Isothermal extrapolation. 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 ! Standard atmosphere -6.5 K/km lapse rate for the extrapolation. 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 ! Adiabatic extrapolation for theta. ELSE IF ( ( extrap_type .EQ. 3 ) .AND. ( var_type .EQ. 'T' ) ) THEN target_y(target_loop) = all_y(1) ! Wild extrapolation for non-temperature vars. 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) ) ! Use a constant value below ground. ELSE IF ( extrap_type .EQ. 2 ) THEN target_y(target_loop) = all_y(1) ELSE IF ( extrap_type .EQ. 3 ) THEN CALL wrf_error_fatal ( '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_fatal ( 'troubles, could not find trapping x locations' ) END IF ! Even or odd order? We can put the value in the middle if this is ! an odd order interpolator. For the even guys, we'll do it twice ! and shift the range one index, then get an average. IF ( n .EQ. 9 ) THEN CALL cubic_spline (all_dim-1, all_x, all_y, P2) ! ! Find the value of function f(x) ! 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_fatal ( '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_fatal ( '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 !--------------------------------------------------------------------- ! cubic spline routines SUBROUTINE cubic_spline (N, XI, FI, P2) ! ! Function to carry out the cubic-spline approximation ! with the second-order derivatives returned. ! 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 ! ! Assign the intervals and function differences ! DO I = 1, N H(I) = XI(I+1) - XI(I) G(I) = FI(I+1) - FI(I) END DO ! ! Evaluate the coefficient matrix elements 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 ! ! Obtain the second-order derivatives ! 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) ! ! Function to solve the tridiagonal linear equation set. ! 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 ! ! Evaluate the elements in the LU decomposition ! 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) ! ! Forward substitution to obtain y ! Y(1) = B(1)/W(1) DO I = 2, L Y(I) = (B(I)-V(I-1)*Y(I-1))/W(I) END DO ! ! Backward substitution to obtain z 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 ! end cubic spline routines !--------------------------------------------------------------------- SUBROUTINE lagrange_interp ( x , y , n , target_x , target_y ) ! Interpolation using Lagrange polynomials. ! P(x) = f(x0)Ln0(x) + ... + f(xn)Lnn(x) ! where Lnk(x) = (x -x0)(x -x1)...(x -xk-1)(x -xk+1)...(x -xn) ! --------------------------------------------- ! (xk-x0)(xk-x1)...(xk-xk-1)(xk-xk+1)...(xk-xn) IMPLICIT NONE INTEGER , INTENT(IN) :: n REAL , DIMENSION(0:n) , INTENT(IN) :: x , y REAL , INTENT(IN) :: target_x REAL , INTENT(OUT) :: target_y ! Local vars 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 #ifndef VERT_UNIT !--------------------------------------------------------------------- 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 ) ! Compute reference pressure and the reference mu. 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 ! Local vars 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 ) ! Compute difference between the dry, total surface pressure and the top pressure. 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 ! Local vars 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 ) ! Compute dry, hydrostatic surface pressure. 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 ! Local vars 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 ) ! Find the largest pressure in the top level. This is our p_top. We are ! assuming that the top level is the location where the pressure is a minimum ! for each column. In cases where the top surface is not isobaric, a ! communicated value must be shared in the calling routine. Also in cases ! where the top surface is not isobaric, care must be taken that the new ! maximum pressure is not greater than the previous value. This test is ! also handled in the calling routine. 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 ! Local vars 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 ) ! Compute potential temperature from temperature and pressure. 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 ! Local vars 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 ) ! Compute temperature from potential temp and pressure. 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 ! Local vars 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 ) ! Integrate the moisture field vertically. Mostly used to get the total ! vapor pressure, which can be subtracted from the total pressure to get ! the dry pressure. 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 ! Local vars 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 ! Is the data upside down? 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 ! Get a surface value, always the first level of a 3d field. 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 ) ! Initialize the integrated quantity of moisture to zero. 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 ! Find the first level above the ground. If all of the levels are above ground, such as ! a terrain following lower coordinate, then the first level above ground is index #2. 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_fatal ( '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 ! Account for the moisture above the ground. 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 ! Account for the moisture between the surface and the first level up. 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 ! Fix the underground values. 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 ) ! This subroutine computes mixing ratio (q, kg/kg) from basic variables ! pressure (p, Pa), temperature (t, K) and relative humidity (rh, 0-100%). ! Phase transition, liquid water to ice, occurs over (0,-23) temperature range (Celcius). ! Formulation used here is based on: ! WMO, General meteorological standards and recommended practices, ! Appendix A, WMO Technical Regulations, WMO-No. 49, corrigendum, ! August 2000. --TKW 03/30/2011 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 ! Local vars 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 ! Coefficients for esat over liquid water 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 ! Coefficients for esat over ice 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 ! 1 ppm is a reasonable estimate for minimum QV even for stratospheric altitudes REAL, PARAMETER :: QV_MIN = 1.e-6 ! Maximum allowed QV is computed under the extreme condition: ! Saturated at 40 degree in Celcius and 1000 hPa REAL, PARAMETER :: QV_MAX = 0.045 ! Need to constrain WVP in the stratosphere where pressure ! is low but tempearure is hot (warm) ! Maximum ratio of e/p, = q/(0.622+q) 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 ! Saturation WVP wvp = 0.01*rh(i,k,j)*es ! Actual WVP pmb = p(i,k,j)/100. wvpmax = EP_MAX*pmb ! Prevents unrealistic QV in the stratosphere 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 ! Over liquid water 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 ! Over ice 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 ! Mixed 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 ! Over liquid water pwr = ci1*(Ta-1.0) + ci2*LOG10(Ta) + ci3*(1.0-Tb) + ci4 esi = 10.0**pwr ! Over ice 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 ! Prevents unrealistic QV in the stratosphere wvp = MIN(wvp,wvpmax) q(i,k,j) = eps*wvp/(pmb-wvp) END DO END DO END DO END IF ! For pressures above a defined level, reasonable Qv values should be ! a certain value or smaller. If they are larger than this, the input data ! probably had "missing" RH, and we filled in some values. This is an ! attempt to catch those. Also, set the minimum value for the entire ! domain that is above the selected pressure level. 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 ! Local vars 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 ! This subroutine computes mixing ratio (q, kg/kg) from basic variables ! pressure (p, Pa), temperature (t, K) and relative humidity (rh, 1-100%). ! The reference temperature (t_ref, C) is used to describe the temperature ! at which the liquid and ice phase change occurs. 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 ! es is reduced by RH here to avoid problems in low-pressure cases 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 ! Obviously dry. IF ( t1 .lt. -200. ) THEN q(i,k,j) = 0 ELSE ! First compute the ambient vapor pressure of water ! Liquid phase t > 0 C IF ( t1 .GE. t_ref ) THEN ew = a0 + t1 * (a1 + t1 * (a2 + t1 * (a3 + t1 * (a4 + t1 * (a5 + t1 * a6))))) ! Mixed phase -47 C < t < 0 C ELSE IF ( ( t1 .LT. t_ref ) .AND. ( t1 .GE. -47. ) ) THEN ew = es0 * exp(17.67 * t1 / ( t1 + 243.5)) ! Ice phase t < -47 C 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 ! Now sat vap pres obtained compute local vapor pressure ew = MAX ( ew , 0. ) * rh(i,k,j) * 0.01 ! Now compute the specific humidity using the partial vapor ! pressures of water vapor (ew) and dry air (p-ew). The ! constants assume that the pressure is in hPa, so we divide ! the pressures by 100. 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 ! For pressures above a defined level, reasonable Qv values should be ! a certain value or smaller. If they are larger than this, the input data ! probably had "missing" RH, and we filled in some values. This is an ! attempt to catch those. Also, set the minimum value for the entire ! domain that is above the selected pressure level. 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 !--------------------------------------------------------------------- #if 0 program foo ! Make this local variable have the same value as in ! frame/module_driver_constants.F: MAX_ETA integer , parameter :: max_eta = 10001 INTEGER :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte real :: max_dz = 1000 real :: p_top = 100 real :: g = 9.81 real :: p00 = 100000 real :: cvpm = -0.714285731 real :: a = 50 real :: r_d = 287 real :: cp = 1004.5 real :: t00 = 290 real :: p1000mb = 100000 real :: t0 = 300 real :: tiso = 216.649994 real :: p_strat = 5500 real :: a_strat = -12 real , dimension(max_eta) :: znw , eta_levels eta_levels = -1 kds=1 kms=1 kts=1 kde=70 kme=70 kte=70 call 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 ) end program foo #endif 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 ) ! Compute eta levels, either using given values from the namelist (hardly ! a computation, yep, I know), or assuming a constant dz above the PBL, ! knowing p_top and the number of eta levels. 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 ! Local vars 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 ! Gee, do the eta levels come in from the namelist? IF ( ABS(eta_levels(1)+1.) .GT. 0.0000001 ) THEN ! Check to see if the array is oriented OK, we can easily fix an upside down oops. 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_fatal ( 'First eta level should be 1.0 and the last 0.0 in namelist' ) END IF ! Check to see if the input full-level eta array is monotonic. 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_fatal ( 'Fix non-monotonic "eta_levels" in the namelist.input file' ) END IF END DO ! Compute eta levels assuming a constant delta z above the PBL. ELSE IF( auto_levels_opt == 1 ) THEN print *,'using old automatic levels program' ! Compute top of the atmosphere with some silly levels. We just want to ! integrate to get a reasonable value for ztop. We use the planned PBL-esque ! levels, and then just coarse resolution above that. We know p_top, and we ! have the base state vars. 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 ! Base state mu is defined as base state surface pressure minus p_top mub = p_surf - p_top ! Integrate base geopotential, starting at terrain elevation. phb(1) = 0._8 DO k = 2,prac_levels phb(k) = phb(k-1) - dnw_prac(k-1)*mub*alb(k-1) END DO ! So, now we know the model top in meters. Get the average depth above the PBL ! of each of the remaining levels. We are going for a constant delta z thickness. 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_fatal ( 'Add more levels to namelist.input for e_vert' ) END IF ! Standard levels near the surface so no one gets in trouble. DO k = 1 , 8 eta_levels(k) = znw_prac(k) END DO ! Using d phb(k)/ d eta(k) = -mub * alb(k), eqn 2.9 ! Skamarock et al, NCAR TN 468. Use full levels, so ! use twice the thickness. 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 ! temp = t00 + A*LOG(pb/p00) 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 ! temp = t00 + A*LOG(pb/p00) 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 ! There is some iteration. We want the top level, ztop, to be ! consistent with the delta z, and we want the half level values ! to be consistent with the eta levels. The inner loop to 10 gets ! the eta levels very accurately, but has a residual at the top, due ! to dz changing. We reset dz five times, and then things seem OK. 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 ! Here is where we check the eta levels values we just computed. 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 ! Reset the model top and the dz, and iterate. 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_fatal ( 'dz above fixed eta levels is too large') END IF ! Add those 2 levels back into the middle, just above the 8 levels ! that semi define a boundary layer. After we open up the levels, ! then we just linearly interpolate in znw. So now levels 1-8 are ! specified as the fixed boundary layer levels given in this routine. ! The top levels, 12 through kte are those computed. The middle ! levels 9, 10, and 11 are equi-spaced in znw, and are each 1/2 the ! the znw thickness of levels 11 through 12. 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_fatal ( '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 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. ! isothermal temperature used for z/log p relation - tt=290 fits dzbot 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_fatal ( '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 ! isothermal temp 1.5 times stratosphere temp 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_fatal ( '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) !1000 format(10g10.3) 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 ) ! Plow through each month, find the max, min values for each i,j. 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 ! Local vars 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_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 ) ! Linrarly in time interpolate data to a current valid time. The data is ! assumed to come in "monthly", valid at the 15th of every month. 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 ! Local vars 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 ) ! Given current date, select time-matching monthly entry from grid. ! No interpolation. 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 !46 REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_out ! Local vars INTEGER :: i , j INTEGER :: julyr, julday, eightday REAL :: gmt CALL get_julgmt ( date_str , julyr , julday , gmt ) eightday = ((julday-1) / 8) + 1 ! print *, 'date_str: ', date_str ! print *, 'julyr, julday: ', julyr, julday ! print *, 'eightday: ', eightday 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 ) ! Computes the surface pressure using the input height, ! temperature and q (already computed from relative ! humidity) on p surfaces. Sea level pressure is used ! to extrapolate a first guess. 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 ) ! We either compute the surface pressure from a time averaged surface temperature ! (what we will call the "easy way"), or we try to remove the diurnal impact on the ! surface temperature (what we will call the "other way"). Both are essentially ! corrections to a sea level pressure with a high-resolution topography field. 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 ! Find the locations of the 850, 700 and 500 mb levels. k850 = 0 ! find k at: P=850 k700 = 0 ! P=700 k500 = 0 ! P=500 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 #if 0 ! Possibly it is just that we have a generalized vertical coord, so we do not ! have the values exactly. Do a simple assignment to a close vertical level. 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 = kts+1 , kte-1 IF ( ( p(i,k,j) - 85000. ) * ( p(i,k+1,j) - 85000. ) .LE. 0.0 ) THEN k850(i,j) = k END IF IF ( ( p(i,k,j) - 70000. ) * ( p(i,k+1,j) - 70000. ) .LE. 0.0 ) THEN k700(i,j) = k END IF IF ( ( p(i,k,j) - 50000. ) * ( p(i,k+1,j) - 50000. ) .LE. 0.0 ) THEN k500(i,j) = k END IF END DO END DO END DO ! If we *still* do not have the k levels, punt. I mean, we did try. OK = .TRUE. 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 ( ( k850(i,j) .EQ. 0 ) .OR. ( k700(i,j) .EQ. 0 ) .OR. ( k500(i,j) .EQ. 0 ) ) THEN OK = .FALSE. PRINT '(A)','(i,j) = ',i,j,' Error in finding p level for 850, 700 or 500 hPa.' DO K = kts+1 , kte PRINT '(A,I3,A,F10.2,A)','K = ',k,' PRESSURE = ',p(i,k,j),' Pa' END DO PRINT '(A)','Expected 850, 700, and 500 mb values, at least.' END IF END DO END DO IF ( .NOT. OK ) THEN CALL wrf_error_fatal ( 'wrong pressure levels' ) END IF #endif ! We are here if the data is isobaric and we found the levels for 850, 700, ! and 500 mb right off the bat. 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 ! The 850 hPa level of geopotential height is called something special. 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 ! The variable ht is now -ter/ht(850 hPa). The plot thickens. 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 ! Make an isothermal assumption to get a first guess at the surface ! pressure. This is to tell us which levels to use for the lapse ! rates in a bit. 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 ! Get a pressure more than pconst Pa above the surface - p1. The ! p1 is the top of the level that we will use for our lapse rate ! computations. 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 ! Compute virtual temperatures for k850, k700, and k500 layers. Now ! you see why we wanted Q on pressure levels, it all is beginning ! to make sense. 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 ! Compute lapse rates between these three levels. These are ! environmental values for each (i,j). 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 ! From our temperature way up in the air, we extrapolate down to ! the sea level to get a guess at the sea level 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 tslv(i,j) = t1(i,j) * (pslv(i,j) / p1(i,j)) ** gammarg END DO END DO ! The new surface temperature is computed from the with new sea level ! temperature, just using the elevation and a lapse rate. This lapse ! rate is -6.5 K/km. 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 ! A small correction to the sea-level temperature, in case it is too warm. 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 ! Finally, we can get to the surface pressure. 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 ! Surface pressure and sea-level pressure are the same at sea level. ! 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 ( ABS ( ter(i,j) ) .LT. 0.1 ) THEN ! psfc(i,j) = pslv(i,j) ! END IF ! END DO ! END DO 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 ) ! Computes the surface pressure using the input height, ! temperature and q (already computed from relative ! humidity) on p surfaces. Sea level pressure is used ! to extrapolate a first guess. 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 ! Compute the new surface pressure from the old surface pressure, and a ! known change in elevation at the surface. ! del_z = diff in surface topo, lo-res vs hi-res ! psfc = psfc_in * exp ( g del_z / (Rd Tv_sfc ) ) 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 ) ! Computes the surface pressure by vertically interpolating ! linearly (or log) in z the pressure, to the targeted topography. 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 ! Loop over each grid point 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 ! Special case where near the ocean level. Assume that the SLP is a good value. 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 ! Find the trapping levels found_loc = .FALSE. ! Normal sort of scenario - the model topography is somewhere between ! the height values of 1000 mb and the top of the model. 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 ! Interpolate betwixt slp and the first isobaric level above - this is probably the ! usual thing over the ocean. 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 ! Did we do what we wanted done. 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_fatal ( ' 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 ! Local vars 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 ! The filtering is a simple average on a latitude loop. Possibly a LONG list of ! numbers. We assume that ALL of the 2d arrays have been transposed so that ! each patch has the entire domain size of the i-dim local. IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN CALL wrf_error_fatal ( 'filtering assumes all values on X' ) END IF ! Starting at the south pole, we find where the ! grid distance is big enough, then go back a point. Continuing to the ! north pole, we find the first small grid distance. These are the ! computational latitude loops and the associated computational poles. 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 ! Set output values to initial input topo values for whole patch. 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 ! Filter the topo at the negative lats. DO j = MIN(j_lat_neg,jte) , jts , -1 ! i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 ) 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 ! Filter the topo at the positive lats. DO j = MAX(j_lat_pos,jts) , MIN(jde-1,jte) ! i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 ) 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 ! Set output values to initial input topo values for whole patch. 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 ! Local vars 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 ! The filtering is a simple average on a latitude loop. Possibly a LONG list of ! numbers. We assume that ALL of the 2d arrays have been transposed so that ! each patch has the entire domain size of the i-dim local. IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN CALL wrf_error_fatal ( 'filtering assumes all values on X' ) END IF ! Starting at the south pole, we find where the ! grid distance is big enough, then go back a point. Continuing to the ! north pole, we find the first small grid distance. These are the ! computational latitude loops and the associated computational poles. 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 ! Set output values to initial input topo values for whole patch. 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 ! Filter the topo at the negative lats. 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 ! Filter the topo at the positive lats. 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 ! Set output values to initial input topo values for whole patch. 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 !--------------------------------------------------------------------- !+---+-----------------------------------------------------------------+ ! Begin addition by Greg Thompson to dry out the stratosphere. ! Starting 3 levels below model top, go downward and search for where ! Theta gradient over three K-levels is less steep than +10 K per 1500 m. ! This threshold approximates a vertical line on a skew-T chart from ! approximately 300 to 240 mb, anything more unstable than this reference ! is probably in the troposphere so pick the K plus 1 point as the ! tropopause and set mixing ratio to a really small values above. !..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 !..Last modified: 30 Dec 2004 !+---+-----------------------------------------------------------------+ 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 ! Local vars 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 ! Saturation vapor pressure at T = -85C. 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 !+---+-----------------------------------------------------------------+ !..Hardwire snow cover above a pre-specified altitude. !.. Starting altitude for snow (snow_startz) depends on latitude !.. and is 3900 m at 35-deg lowering to 250km (linearly) by 65-deg lat. !.. Alter WEASD linear function from 0 at snow_startz to 999 mm at 4 km. !.. Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 !.. Last modified: 27 Dec 2008 !+---+-----------------------------------------------------------------+ 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 !+---+-----------------------------------------------------------------+ !..Table of lookup values of radiative effective radius of ice crystals !.. as a function of Temperature from -94C to 0C. Taken from WRF RRTMG !.. radiation code where it is attributed to Jon Egill Kristjansson !.. and coauthors. !+---+-----------------------------------------------------------------+ 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/ !+---+-----------------------------------------------------------------+ !..From the model 3D temperature field, subtract 179K for which !.. index value of retab as a start. Value of corr is for !.. interpolating between neighboring values in the table. !+---+-----------------------------------------------------------------+ 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 !+---+-----------------------------------------------------------------+ !..Now we have the final radiative effective size of ice (as function !.. of temperature only). This size represents 3rd moment divided by !.. second moment of the ice size distribution, so we can compute a !.. number concentration from the mean size and mass mixing ratio. !.. The mean (radiative effective) diameter is 3./Slope for an inverse !.. exponential size distribution. So, starting with slope, work !.. backwords to get number concentration. !+---+-----------------------------------------------------------------+ lambda = 3.0 / deice make_IceNumber = Q_ice * lambda*lambda*lambda / (PI*Ice_density) !+---+-----------------------------------------------------------------+ !..Example1: Common ice size coming from Thompson scheme is about 30 microns. !.. An example ice mixing ratio could be 0.001 g/kg for a temperature of -50C. !.. Remember to convert both into MKS units. This gives N_ice=357652 per kg. !..Example2: Lower in atmosphere at T=-10C matching ~162 microns in retab, !.. and assuming we have 0.1 g/kg mixing ratio, then N_ice=28122 per kg, !.. which is 28 crystals per liter of air if the air density is 1.0. !+---+-----------------------------------------------------------------+ 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 !--- Ocean xDc = 17.E-6 nu_c = 12 else !--- Land 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. !+---+-----------------------------------------------------------------+ !.. Not thrilled with it, but set Y-intercept parameter to Marshal-Palmer value !.. that basically assumes melting snow becomes typical rain. However, for !.. -2C < T < 0C, make linear increase in exponent to attempt to keep !.. supercooled collision-coalescence (warm-rain) similar to drizzle rather !.. than bigger rain drops. While this could also exist at T>0C, it is !.. more difficult to assume it directly from having mass and not number. !+---+-----------------------------------------------------------------+ 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 #endif